diff options
author | Stuart Sierra <mail@stuartsierra.com> | 2010-01-20 15:39:56 -0500 |
---|---|---|
committer | Stuart Sierra <mail@stuartsierra.com> | 2010-01-20 15:39:56 -0500 |
commit | 2ede388a9267d175bfaa7781ee9d57532eb4f20f (patch) | |
tree | bb42002af196405d7e25cc4e30b4c1c9de5c06d5 /src/clojure | |
parent | 1bc820d96048a6536706ff999e9892649b53c700 (diff) |
Move source files into Maven-style directory structure.
Diffstat (limited to 'src/clojure')
151 files changed, 0 insertions, 23750 deletions
diff --git a/src/clojure/contrib/accumulators.clj b/src/clojure/contrib/accumulators.clj deleted file mode 100644 index dcd03dd1..00000000 --- a/src/clojure/contrib/accumulators.clj +++ /dev/null @@ -1,324 +0,0 @@ -;; Accumulators - -;; by Konrad Hinsen -;; last updated May 19, 2009 - -;; This module defines various accumulators (list, vector, map, -;; sum, product, counter, and combinations thereof) with a common -;; interface defined by the multimethods add and combine. -;; For each accumulator type, its empty value is defined in this module. -;; Applications typically use this as a starting value and add data -;; using the add multimethod. - -;; Copyright (c) Konrad Hinsen, 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. - -(ns - #^{:author "Konrad Hinsen" - :doc "A generic accumulator interface and implementations of various - accumulators."} - clojure.contrib.accumulators - (:refer-clojure :exclude (deftype)) - (:use [clojure.contrib.types :only (deftype)]) - (:use [clojure.contrib.def :only (defvar defvar- defmacro-)]) - (:require [clojure.contrib.generic.arithmetic :as ga])) - -(defmulti add - "Add item to the accumulator acc. The exact meaning of adding an - an item depends on the type of the accumulator." - {:arglists '([acc item])} - (fn [acc item] (type acc))) - -(defn add-items - "Add all elements of a collection coll to the accumulator acc." - [acc items] - (reduce add acc items)) - -(defmulti combine - "Combine the values of the accumulators acc1 and acc2 into a - single accumulator of the same type." - {:arglists '([& accs])} - (fn [& accs] (type (first accs)))) - -; -; An ::accumulator type tag is attached to tbe built-in types -; when used as accumulators, and new types are derived from it. -; Multimethods add and combine for ::accumulator sub-dispatch on class. -; We also define generic addition as the combine operation. -; -(let [meta-map {:type ::accumulator}] - (defn- with-acc-tag - [x] - (with-meta x meta-map))) - -(defmethod add ::accumulator - [a e] - ((get-method add (class a)) a e)) - -(defmethod combine ::accumulator - [& as] - (apply (get-method combine (class (first as))) as)) - -(defmethod ga/+ ::accumulator - [x y] - (combine x y)) - -; -; Vector accumulator -; -(defvar empty-vector (with-acc-tag []) - "An empty vector accumulator. Adding an item appends it at the end.") - -(defmethod combine clojure.lang.IPersistentVector - [& vs] - (with-acc-tag (vec (apply concat vs)))) - -(defmethod add clojure.lang.IPersistentVector - [v e] - (with-acc-tag (conj v e))) - -; -; List accumulator -; -(defvar empty-list (with-acc-tag '()) - "An empty list accumulator. Adding an item appends it at the beginning.") - -(defmethod combine clojure.lang.IPersistentList - [& vs] - (with-acc-tag (apply concat vs))) - -(defmethod add clojure.lang.IPersistentList - [v e] - (with-acc-tag (conj v e))) - -; -; Queue accumulator -; -(defvar empty-queue (with-acc-tag clojure.lang.PersistentQueue/EMPTY) - "An empty queue accumulator. Adding an item appends it at the end.") - -(defmethod combine clojure.lang.PersistentQueue - [& vs] - (add-items (first vs) (apply concat (rest vs)))) - -(defmethod add clojure.lang.PersistentQueue - [v e] - (with-acc-tag (conj v e))) - -; -; Set accumulator -; -(defvar empty-set (with-acc-tag #{}) - "An empty set accumulator.") - -(defmethod combine (class empty-set) - [& vs] - (with-acc-tag (apply clojure.set/union vs))) - -(defmethod add (class empty-set) - [v e] - (with-acc-tag (conj v e))) - -; -; String accumulator -; -(defvar empty-string "" - "An empty string accumulator. Adding an item (string or character) - appends it at the end.") - -(defmethod combine java.lang.String - [& vs] - (apply str vs)) - -(defmethod add java.lang.String - [v e] - (str v e)) - -; -; Map accumulator -; -(defvar empty-map (with-acc-tag {}) - "An empty map accumulator. Items to be added must be [key value] pairs.") - -(defmethod combine clojure.lang.IPersistentMap - [& vs] - (with-acc-tag (apply merge vs))) - -(defmethod add clojure.lang.IPersistentMap - [v e] - (with-acc-tag (conj v e))) - -; -; Numerical accumulators: sum, product, minimum, maximum -; -(defmacro- defacc - [name op empty doc-string] - (let [type-tag (keyword (str *ns*) (str name)) - empty-symbol (symbol (str "empty-" name))] - `(let [op# ~op] - (deftype ~type-tag ~name - (fn [~'x] {:value ~'x}) - (fn [~'x] (list (:value ~'x)))) - (derive ~type-tag ::accumulator) - (defvar ~empty-symbol (~name ~empty) ~doc-string) - (defmethod combine ~type-tag [& vs#] - (~name (apply op# (map :value vs#)))) - (defmethod add ~type-tag [v# e#] - (~name (op# (:value v#) e#)))))) - -(defacc sum + 0 - "An empty sum accumulator. Only numbers can be added.") - -(defacc product * 1 - "An empty sum accumulator. Only numbers can be added.") - -; The empty maximum accumulator should have value -infinity. -; This is represented by nil and taken into account in an -; adapted max function. In the minimum accumulator, nil is -; similarly used to represent +infinity. - -(defacc maximum (fn [& xs] - (when-let [xs (seq (filter identity xs))] - (apply max xs))) - nil - "An empty maximum accumulator. Only numbers can be added.") - -(defacc minimum (fn [& xs] - (when-let [xs (seq (filter identity xs))] - (apply min xs))) - nil - "An empty minimum accumulator. Only numbers can be added.") - -; -; Numeric min-max accumulator -; (combination of minimum and maximum) -; -(deftype ::min-max min-max - (fn [min max] {:min min :max max}) - (fn [mm] (list (:min mm) (:max mm)))) - -(derive ::min-max ::accumulator) - -(defvar empty-min-max (min-max nil nil) - "An empty min-max accumulator, combining minimum and maximum. - Only numbers can be added.") - -(defmethod combine ::min-max - [& vs] - (let [total-min (apply min (map :min vs)) - total-max (apply max (map :max vs))] - (min-max total-min total-max))) - -(defmethod add ::min-max - [v e] - (let [min-v (:min v) - max-v (:max v) - new-min (if (nil? min-v) e (min min-v e)) - new-max (if (nil? max-v) e (max max-v e))] - (min-max new-min new-max))) - -; -; Mean and variance accumulator -; -(deftype ::mean-variance mean-variance) - -(derive ::mean-variance ::accumulator) - -(defvar empty-mean-variance (mean-variance {:n 0 :mean 0 :variance 0}) - "An empty mean-variance accumulator, combining sample mean and - sample variance. Only numbers can be added.") - -(defmethod combine ::mean-variance - ([mv] - mv) - - ([mv1 mv2] - (let [{n1 :n mean1 :mean var1 :variance} mv1 - {n2 :n mean2 :mean var2 :variance} mv2 - n (+ n1 n2) - mean (/ (+ (* n1 mean1) (* n2 mean2)) n) - sq #(* % %) - c (+ (* n1 (sq (- mean mean1))) (* n2 (sq (- mean mean2)))) - var (if (< n 2) - 0 - (/ (+ c (* (dec n1) var1) (* (dec n2) var2)) (dec n)))] - (mean-variance {:n n :mean mean :variance var}))) - - ([mv1 mv2 & mvs] - (reduce combine (combine mv1 mv2) mvs))) - -(defmethod add ::mean-variance - [mv x] - (let [{n :n mean :mean var :variance} mv - n1 (inc n) - d (- x mean) - new-mean (+ mean (/ d n1)) - new-var (if (zero? n) 0 (/ (+ (* (dec n) var) (* d (- x new-mean))) n))] - (mean-variance {:n n1 :mean new-mean :variance new-var}))) - -; -; Counter accumulator -; -(deftype ::counter counter) - -(derive ::counter ::accumulator) - -(defvar empty-counter (counter {}) - "An empty counter accumulator. Its value is a map that stores for - every item the number of times it was added.") - -(defmethod combine ::counter - [v & vs] - (letfn [(add-item [cntr [item n]] - (assoc cntr item (+ n (get cntr item 0)))) - (add-two [c1 c2] (reduce add-item c1 c2))] - (reduce add-two v vs))) - -(defmethod add ::counter - [v e] - (assoc v e (inc (get v e 0)))) - -; -; Counter accumulator with total count -; -(deftype ::counter-with-total counter-with-total) -(derive ::counter-with-total ::counter) - -(defvar empty-counter-with-total - (counter-with-total {:total 0}) - "An empty counter-with-total accumulator. It works like the counter - accumulator, except that the total number of items added is stored as the - value of the key :total.") - -(defmethod add ::counter-with-total - [v e] - (assoc v e (inc (get v e 0)) - :total (inc (:total v)))) - -; -; Accumulator n-tuple -; -(deftype ::tuple acc-tuple) - -(derive ::tuple ::accumulator) - -(defn empty-tuple - "Returns an accumulator tuple with the supplied empty-accumulators - as its value. Accumulator tuples consist of several accumulators that - work in parallel. Added items must be sequences whose number of elements - matches the number of sub-accumulators." - [empty-accumulators] - (acc-tuple (into [] empty-accumulators))) - -(defmethod combine ::tuple - [& vs] - (acc-tuple (vec (map combine vs)))) - -(defmethod add ::tuple - [v e] - (acc-tuple (vec (map add v e)))) diff --git a/src/clojure/contrib/accumulators/examples.clj b/src/clojure/contrib/accumulators/examples.clj deleted file mode 100644 index b9dcbee5..00000000 --- a/src/clojure/contrib/accumulators/examples.clj +++ /dev/null @@ -1,93 +0,0 @@ -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; Accumulator application examples -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(ns - #^{:author "Konrad Hinsen" - :skip-wiki true - :doc "Examples for using accumulators"} - clojure.contrib.accumulators.examples - (:use [clojure.contrib.accumulators - :only (combine add add-items - empty-vector empty-list empty-queue empty-set empty-map - empty-counter empty-counter-with-total - empty-sum empty-product empty-maximum empty-minimum - empty-min-max empty-mean-variance empty-string empty-tuple)])) - -; Vector accumulator: combine is concat, add is conj -(combine [:a :b] [:c :d] [:x :y]) -(add [:a :b] :c) -(add-items empty-vector [:a :b :a]) - -; List accumulator: combine is concat, add is conj -(combine '(:a :b) '(:c :d) '(:x :y)) -(add '(:a :b) :c) -(add-items empty-list [:a :b :a]) - -; Queue accumulator -(let [q1 (add-items empty-queue [:a :b :a]) - q2 (add-items empty-queue [:x :y])] - (combine q1 q2)) - -; Set accumulator: combine is union, add is conj -(combine #{:a :b} #{:c :d} #{:a :d}) -(add #{:a :b} :c) -(add-items empty-set [:a :b :a]) - -; Map accumulator: combine is merge, add is conj -(combine {:a 1} {:b 2 :c 3} {}) -(add {:a 1} [:b 2]) -(add-items empty-map [[:a 1] [:b 2] [:a 0]]) - -; Counter accumulator -(let [c1 (add-items empty-counter [:a :b :a]) - c2 (add-items empty-counter [:x :y])] - (combine c1 c2)) - -; Counter-with-total accumulator -(let [c1 (add-items empty-counter-with-total [:a :b :a]) - c2 (add-items empty-counter-with-total [:x :y])] - (combine c1 c2)) - -; Sum accumulator: combine is addition -(let [s1 (add-items empty-sum [1 2 3]) - s2 (add-items empty-sum [-1 -2 -3])] - (combine s1 s2)) - -; Product accumulator: combine is multiplication -(let [p1 (add-items empty-product [2 3]) - p2 (add-items empty-product [(/ 1 2)])] - (combine p1 p2)) - -; Maximum accumulator: combine is max -(let [m1 (add-items empty-maximum [2 3]) - m2 (add-items empty-maximum [(/ 1 2)])] - (combine m1 m2)) - -; Minimum accumulator: combine is min -(let [m1 (add-items empty-minimum [2 3]) - m2 (add-items empty-minimum [(/ 1 2)])] - (combine m1 m2)) - -; Min-max accumulator: combination of minimum and maximum -(let [m1 (add-items empty-min-max [2 3]) - m2 (add-items empty-min-max [(/ 1 2)])] - (combine m1 m2)) - -; Mean-variance accumulator: sample mean and sample variance -(let [m1 (add-items empty-mean-variance [2 4]) - m2 (add-items empty-mean-variance [6])] - (combine m1 m2)) - -; String accumulator: combine is concatenation -(combine "a" "b" "c" "def") -(add "a" (char 44)) -(add-items empty-string [(char 55) (char 56) (char 57)]) - -; Accumulator tuples permit to update several accumulators in parallel -(let [pair (empty-tuple [empty-vector empty-string])] - (add-items pair [[1 "a"] [2 "b"]])) diff --git a/src/clojure/contrib/agent_utils.clj b/src/clojure/contrib/agent_utils.clj deleted file mode 100644 index 0ab845d5..00000000 --- a/src/clojure/contrib/agent_utils.clj +++ /dev/null @@ -1,35 +0,0 @@ -; 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. - -;; misc agent utilities - -;; note to other contrib members: feel free to add to this lib - -(ns - #^{:author "Christophe Grande", - :doc "Miscellaneous agent utilities - (note to other contrib members: feel free to add to this lib)", -} - clojure.contrib.agent-utils) - -(defmacro capture-and-send - "Capture the current value of the specified vars and rebind - them on the agent thread before executing the action. - - Example: - (capture-and-send [*out*] a f b c)" - - [vars agent action & args] - (let [locals (map #(gensym (name %)) vars)] - `(let [~@(interleave locals vars) - action# (fn [& args#] - (binding [~@(interleave vars locals)] - (apply ~action args#)))] - (send ~agent action# ~@args)))) diff --git a/src/clojure/contrib/apply_macro.clj b/src/clojure/contrib/apply_macro.clj deleted file mode 100644 index 19a926d3..00000000 --- a/src/clojure/contrib/apply_macro.clj +++ /dev/null @@ -1,43 +0,0 @@ -;;; apply_macro.clj: make macros behave like functions - -;; by Stuart Sierra, http://stuartsierra.com/ -;; January 28, 2009 - -;; Copyright (c) Stuart Sierra, 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. - - -;; Don't use this. I mean it. It's evil. How evil? You can't -;; handle it, that's how evil it is. That's right. I did it so you -;; don't have to, ok? Look but don't touch. Use this lib and you'll -;; go blind. - - -(ns clojure.contrib.apply-macro) - -;; Copied from clojure.core/spread, which is private. -(defn- spread - "Flatten final argument list as in apply." - [arglist] - (cond - (nil? arglist) nil - (nil? (rest arglist)) (seq (first arglist)) - :else (cons (first arglist) (spread (rest arglist))))) - -(defmacro apply-macro - "This is evil. Don't ever use it. It makes a macro behave like a - function. Seriously, how messed up is that? - - Evaluates all args, then uses them as arguments to the macro as with - apply. - - (def things [true true false]) - (apply-macro and things) - ;; Expands to: (and true true false)" - [macro & args] - (cons macro (spread (map eval args)))) diff --git a/src/clojure/contrib/base64.clj b/src/clojure/contrib/base64.clj deleted file mode 100644 index 5e1e3310..00000000 --- a/src/clojure/contrib/base64.clj +++ /dev/null @@ -1,99 +0,0 @@ -;;; base64.clj: Experimental Base-64 encoding and (later) decoding - -;; by Stuart Sierra, http://stuartsierra.com/ -;; August 19, 2009 - -;; Copyright (c) Stuart Sierra, 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. - - -(ns #^{:doc "Base-64 encoding and (maybe later) decoding. - - This is mainly here as an example. It is much slower than the - Apache Commons Codec implementation or sun.misc.BASE64Encoder." - :author "Stuart Sierra"} - clojure.contrib.base64 - (:import (java.io InputStream Writer ByteArrayInputStream - StringWriter))) - -(def *base64-alphabet* - "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/=") - -(defn encode - "Encodes bytes of input, writing Base 64 text on output. alphabet - is a 65-character String containing the 64 characters to use in the - encoding; the 65th character is the pad character. line-length is - the maximum number of characters per line, nil for no line breaks." - [#^InputStream input #^Writer output #^String alphabet line-length] - (let [buffer (make-array Byte/TYPE 3)] - (loop [line 0] - (let [len (.read input buffer)] - (when (pos? len) - ;; Pre-boxing the bytes as Integers is more efficient for - ;; Clojure's bit operations. - (let [b0 (Integer/valueOf (int (aget buffer 0))) - b1 (Integer/valueOf (int (aget buffer 1))) - b2 (Integer/valueOf (int (aget buffer 2)))] - (cond (= len 3) - (let [s0 (bit-and 0x3F (bit-shift-right b0 2)) - s1 (bit-and 0x3F - (bit-or (bit-shift-left b0 4) - (bit-shift-right b1 4))) - s2 (bit-and 0x3F - (bit-or (bit-shift-left b1 2) - (bit-shift-right b2 6))) - s3 (bit-and 0x3F b2)] - (.append output (.charAt alphabet s0)) - (.append output (.charAt alphabet s1)) - (.append output (.charAt alphabet s2)) - (.append output (.charAt alphabet s3))) - - (= len 2) - (let [s0 (bit-and 0x3F (bit-shift-right b0 2)) - s1 (bit-and 0x3F - (bit-or (bit-shift-left b0 4) - (bit-shift-right b1 4))) - s2 (bit-and 0x3F (bit-shift-left b1 2))] - (.append output (.charAt alphabet s0)) - (.append output (.charAt alphabet s1)) - (.append output (.charAt alphabet s2)) - (.append output (.charAt alphabet 64))) - - (= len 1) - (let [s0 (bit-and 0x3F (bit-shift-right b0 2)) - s1 (bit-and 0x3F (bit-shift-left b0 4))] - (.append output (.charAt alphabet s0)) - (.append output (.charAt alphabet s1)) - (.append output (.charAt alphabet 64)) - (.append output (.charAt alphabet 64))))) - (if (and line-length (> (+ line 4) line-length)) - (do (.append output \newline) - (recur 0)) - (recur (+ line 4)))))))) - -(defn encode-str - "Encodes String in base 64; returns a String. If not specified, - encoding is UTF-8 and line-length is nil." - ([s] (encode-str s "UTF-8" nil)) - ([#^String s #^String encoding line-length] - (let [output (StringWriter.)] - (encode (ByteArrayInputStream. (.getBytes s encoding)) - output *base64-alphabet* line-length) - (.toString output)))) - - -;;; tests - -;; (deftest t-encode-str -;; (is (= (encode-str "") "")) -;; (is (= (encode-str "f") "Zg==")) -;; (is (= (encode-str "fo") "Zm8=")) -;; (is (= (encode-str "foo") "Zm9v")) -;; (is (= (encode-str "foob") "Zm9vYg==")) -;; (is (= (encode-str "fooba") "Zm9vYmE=")) -;; (is (= (encode-str "foobar") "Zm9vYmFy"))) diff --git a/src/clojure/contrib/classpath.clj b/src/clojure/contrib/classpath.clj deleted file mode 100644 index a5a1a6d3..00000000 --- a/src/clojure/contrib/classpath.clj +++ /dev/null @@ -1,39 +0,0 @@ -;;; classpath.clj: utilities for working with the Java class path - -;; by Stuart Sierra, http://stuartsierra.com/ -;; April 19, 2009 - -;; Copyright (c) Stuart Sierra, 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. - - -(ns - #^{:author "Stuart Sierra", - :doc "Utilities for dealing with the JVM's classpath"} - clojure.contrib.classpath - (:require [clojure.contrib.jar :as jar]) - (:import (java.io File) - (java.util.jar JarFile))) - -(defn classpath - "Returns a sequence of File objects of the elements on CLASSPATH." - [] - (map #(File. %) - (.split (System/getProperty "java.class.path") - (System/getProperty "path.separator")))) - -(defn classpath-directories - "Returns a sequence of File objects for the directories on classpath." - [] - (filter #(.isDirectory %) (classpath))) - -(defn classpath-jarfiles - "Returns a sequence of JarFile objects for the JAR files on classpath." - [] - (map #(JarFile. %) (filter jar/jar-file? (classpath)))) - diff --git a/src/clojure/contrib/combinatorics.clj b/src/clojure/contrib/combinatorics.clj deleted file mode 100644 index ca8c8ba2..00000000 --- a/src/clojure/contrib/combinatorics.clj +++ /dev/null @@ -1,164 +0,0 @@ -;;; combinatorics.clj: efficient, functional algorithms for generating lazy
-;;; sequences for common combinatorial functions.
-
-;; by Mark Engelberg (mark.engelberg@gmail.com)
-;; January 27, 2009
-
-(comment
-"
-(combinations items n) - A lazy sequence of all the unique
-ways of taking n different elements from items.
-Example: (combinations [1 2 3] 2) -> ((1 2) (1 3) (2 3))
-
-(subsets items) - A lazy sequence of all the subsets of
-items (but generalized to all sequences, not just sets).
-Example: (subsets [1 2 3]) -> (() (1) (2) (3) (1 2) (1 3) (2 3) (1 2 3))
-
-(cartesian-product & seqs) - Takes any number of sequences
-as arguments, and returns a lazy sequence of all the ways
-to take one item from each seq.
-Example: (cartesian-product [1 2] [3 4]) -> ((1 3) (1 4) (2 3) (2 4))
-(cartesian-product seq1 seq2 seq3 ...) behaves like but is
-faster than a nested for loop, such as:
-(for [i1 seq1 i2 seq2 i3 seq3 ...] (list i1 i2 i3 ...))
-
-(selections items n) - A lazy sequence of all the ways to
-take n (possibly the same) items from the sequence of items.
-Example: (selections [1 2] 3) -> ((1 1 1) (1 1 2) (1 2 1) (1 2 2) (2 1 1) (2 1 2) (2 2 1) (2 2 2))
-
-(permutations items) - A lazy sequence of all the permutations
-of items.
-Example: (permutations [1 2 3]) -> ((1 2 3) (1 3 2) (2 1 3) (2 3 1) (3 1 2) (3 2 1))
-
-(lex-permutations items) - A lazy sequence of all distinct
-permutations in lexicographic order
-(this function returns the permutations as
-vectors). Only works on sequences of comparable
-items. (Note that the result will be quite different from
-permutations when the sequence contains duplicate items.)
-Example: (lex-permutations [1 1 2]) -> ([1 1 2] [1 2 1] [2 1 1])
-
-About permutations vs. lex-permutations:
-lex-permutations is faster than permutations, but only works
-on sequences of numbers. They operate differently
-on sequences with duplicate items (lex-permutations will only
-give you back distinct permutations). lex-permutations always
-returns the permutations sorted lexicographically whereas
-permutations will be in an order where the input sequence
-comes first. In general, I recommend using the regular
-permutations function unless you have a specific
-need for lex-permutations.
-
-About this code:
-These combinatorial functions can be written in an elegant way using recursion. However, when dealing with combinations and permutations, you're usually generating large numbers of things, and speed counts. My objective was to write the fastest possible code I could, restricting myself to Clojure's functional, persistent data structures (rather than using Java's arrays) so that this code could be safely leveraged within Clojure's transactional concurrency system.
-
-I also restricted myself to algorithms that return results in a standard order. For example, there are faster ways to generate cartesian-product, but I don't know of a faster way to generate the results in the standard nested-for-loop order.
-
-Most of these algorithms are derived from algorithms found in Knuth's wonderful Art of Computer Programming books (specifically, the volume 4 fascicles), which present fast, iterative solutions to these common combinatorial problems. Unfortunately, these iterative versions are somewhat inscrutable. If you want to better understand these algorithms, the Knuth books are the place to start.
-
-On my own computer, I use versions of all these algorithms that return sequences built with an uncached variation of lazy-seq. Not only does this boost performance, but it's easier to use these rather large sequences more safely (from a memory consumption standpoint). If some form of uncached sequences makes it into Clojure, I will update this accordingly.
-"
-)
-
-
-(ns
- #^{:author "Mark Engelberg",
- :doc "Efficient, functional algorithms for generating lazy
-sequences for common combinatorial functions. (See the source code
-for a longer description.)"}
- clojure.contrib.combinatorics)
-
-(defn- index-combinations
- [n cnt]
- (lazy-seq
- (let [c (vec (cons nil (for [j (range 1 (inc n))] (+ j cnt (- (inc n)))))),
- iter-comb
- (fn iter-comb [c j]
- (if (> j n) nil
- (let [c (assoc c j (dec (c j)))]
- (if (< (c j) j) [c (inc j)]
- (loop [c c, j j]
- (if (= j 1) [c j]
- (recur (assoc c (dec j) (dec (c j))) (dec j)))))))),
- step
- (fn step [c j]
- (cons (rseq (subvec c 1 (inc n)))
- (lazy-seq (let [next-step (iter-comb c j)]
- (when next-step (step (next-step 0) (next-step 1)))))))]
- (step c 1))))
-
-(defn combinations
- "All the unique ways of taking n different elements from items"
- [items n]
- (let [v-items (vec (reverse items))]
- (if (zero? n) (list ())
- (let [cnt (count items)]
- (cond (> n cnt) nil
- (= n cnt) (list (seq items))
- :else
- (map #(map v-items %) (index-combinations n cnt)))))))
-
-(defn subsets
- "All the subsets of items"
- [items]
- (mapcat (fn [n] (combinations items n))
- (range (inc (count items)))))
-
-(defn cartesian-product
- "All the ways to take one item from each sequence"
- [& seqs]
- (let [v-original-seqs (vec seqs)
- step
- (fn step [v-seqs]
- (let [increment
- (fn [v-seqs]
- (loop [i (dec (count v-seqs)), v-seqs v-seqs]
- (if (= i -1) nil
- (if-let [rst (next (v-seqs i))]
- (assoc v-seqs i rst)
- (recur (dec i) (assoc v-seqs i (v-original-seqs i)))))))]
- (when v-seqs
- (cons (map first v-seqs)
- (lazy-seq (step (increment v-seqs)))))))]
- (when (every? first seqs)
- (lazy-seq (step v-original-seqs)))))
-
-
-(defn selections
- "All the ways of taking n (possibly the same) elements from the sequence of items"
- [items n]
- (apply cartesian-product (take n (repeat items))))
-
-
-(defn- iter-perm [v]
- (let [len (count v),
- j (loop [i (- len 2)]
- (cond (= i -1) nil
- (< (v i) (v (inc i))) i
- :else (recur (dec i))))]
- (when j
- (let [vj (v j),
- l (loop [i (dec len)]
- (if (< vj (v i)) i (recur (dec i))))]
- (loop [v (assoc v j (v l) l vj), k (inc j), l (dec len)]
- (if (< k l)
- (recur (assoc v k (v l) l (v k)) (inc k) (dec l))
- v))))))
-
-(defn- vec-lex-permutations [v]
- (when v (cons v (lazy-seq (vec-lex-permutations (iter-perm v))))))
-
-(defn lex-permutations
- "Fast lexicographic permutation generator for a sequence of numbers"
- [c]
- (lazy-seq
- (let [vec-sorted (vec (sort c))]
- (if (zero? (count vec-sorted))
- (list [])
- (vec-lex-permutations vec-sorted)))))
-
-(defn permutations
- "All the permutations of items, lexicographic by index"
- [items]
- (let [v (vec items)]
- (map #(map v %) (lex-permutations (range (count v))))))
diff --git a/src/clojure/contrib/command_line.clj b/src/clojure/contrib/command_line.clj deleted file mode 100644 index 466dd7a7..00000000 --- a/src/clojure/contrib/command_line.clj +++ /dev/null @@ -1,122 +0,0 @@ -; Copyright (c) Chris Houser, Nov-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. - -; Process command-line arguments according to a given cmdspec - -(ns - #^{:author "Chris Houser", - :doc "Process command-line arguments according to a given cmdspec"} - clojure.contrib.command-line - (:require (clojure.contrib [seq-utils :as su])) - (:use (clojure.contrib [str-utils :only (str-join)]))) - -(defn make-map [args cmdspec] - (let [{spec true [rest-sym] false} (su/group-by vector? cmdspec) - rest-str (str rest-sym) - key-data (into {} (for [[syms [_ default]] (map #(split-with symbol? %) - (conj spec '[help? h?])) - sym syms] - [(re-find #"^.*[^?]" (str sym)) - {:sym (str (first syms)) :default default}])) - defaults (into {} (for [[_ {:keys [default sym]}] key-data - :when default] - [sym default]))] - (loop [[argkey & [argval :as r]] args - cmdmap (assoc defaults :cmdspec cmdspec rest-str [])] - (if argkey - (let [[_ & [keybase]] (re-find #"^--?(.*)" argkey)] - (cond - (= keybase nil) (recur r (update-in cmdmap [rest-str] conj argkey)) - (= keybase "") (update-in cmdmap [rest-str] #(apply conj % r)) - :else (if-let [found (key-data keybase)] - (if (= \? (last (:sym found))) - (recur r (assoc cmdmap (:sym found) true)) - (recur (next r) (assoc cmdmap (:sym found) - (if (or (nil? r) (= \- (ffirst r))) - (:default found) - (first r))))) - (throw (Exception. (str "Unknown option " argkey)))))) - cmdmap)))) - -(defn- align - "Align strings given as vectors of columns, with first vector - specifying right or left alignment (:r or :l) for each column." - [spec & rows] - (let [maxes (vec (for [n (range (count (first rows)))] - (apply max (map (comp count #(nth % n)) rows)))) - fmt (str-join " " - (for [n (range (count maxes))] - (str "%" - (when-not (zero? (maxes n)) - (str (when (= (spec n) :l) "-") (maxes n))) - "s")))] - (str-join "\n" - (for [row rows] - (apply format fmt row))))) - -(defn- rmv-q - "Remove ?" - [#^String s] - (if (.endsWith s "?") - (.substring s 0 (dec (count s))) - s)) - -(defn print-help [desc cmdmap] - (println desc) - (println "Options") - (println - (apply align [:l :l :l] - (for [spec (:cmdspec cmdmap) :when (vector? spec)] - (let [[argnames [text default]] (split-with symbol? spec) - [_ opt q] (re-find #"^(.*[^?])(\??)$" - (str (first argnames))) - argnames (map (comp rmv-q str) argnames) - argnames - (str-join ", " - (for [arg argnames] - (if (= 1 (count arg)) - (str "-" arg) - (str "--" arg))))] - [(str " " argnames (when (= "" q) " <arg>") " ") - text - (if-not default - "" - (str " [default " default "]"))]))))) - -(defmacro with-command-line - "Bind locals to command-line args." - [args desc cmdspec & body] - (let [locals (vec (for [spec cmdspec] - (if (vector? spec) - (first spec) - spec)))] - `(let [{:strs ~locals :as cmdmap#} (make-map ~args '~cmdspec)] - (if (cmdmap# "help?") - (print-help ~desc cmdmap#) - (do ~@body))))) - -(comment - -; example of usage: - -(with-command-line *command-line-args* - "tojs -- Compile ClojureScript to JavaScript" - [[simple? s? "Runs some simple built-in tests"] - [serve "Starts a repl server on the given port" 8081] - [mkboot? "Generates a boot.js file"] - [verbose? v? "Includes extra fn names and comments in js"] - filenames] - (binding [*debug-fn-names* verbose? *debug-comments* verbose?] - (cond - simple? (simple-tests) - serve (start-server (Integer/parseInt serve)) - mkboot? (mkboot) - :else (doseq [filename filenames] - (filetojs filename))))) - -) diff --git a/src/clojure/contrib/complex_numbers.clj b/src/clojure/contrib/complex_numbers.clj deleted file mode 100644 index 01f90b9c..00000000 --- a/src/clojure/contrib/complex_numbers.clj +++ /dev/null @@ -1,293 +0,0 @@ -;; Complex numbers - -;; by Konrad Hinsen -;; last updated May 4, 2009 - -;; Copyright (c) Konrad Hinsen, 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. - -(ns - #^{:author "Konrad Hinsen" - :doc "Complex numbers - NOTE: This library is in evolution. Most math functions are - not implemented yet."} - clojure.contrib.complex-numbers - (:refer-clojure :exclude (deftype)) - (:use [clojure.contrib.types :only (deftype)] - [clojure.contrib.generic :only (root-type)]) - (:require [clojure.contrib.generic.arithmetic :as ga] - [clojure.contrib.generic.comparison :as gc] - [clojure.contrib.generic.math-functions :as gm])) - -; -; Complex numbers are represented as struct maps. The real and imaginary -; parts can be of any type for which arithmetic and maths functions -; are defined. -; -(defstruct complex-struct :real :imag) - -; -; The general complex number type -; -(deftype ::complex complex - (fn [real imag] (struct complex-struct real imag)) - (fn [c] (vals c))) - -(derive ::complex root-type) - -; -; A specialized subtype for pure imaginary numbers. Introducing this type -; reduces the number of operations by eliminating additions with and -; multiplications by zero. -; -(deftype ::pure-imaginary imaginary - (fn [imag] (struct complex-struct 0 imag)) - (fn [c] (list (:imag c)))) - -(derive ::pure-imaginary ::complex) - -; -; Extraction of real and imaginary parts -; -(def real (accessor complex-struct :real)) -(def imag (accessor complex-struct :imag)) - -; -; Equality and zero test -; -(defmethod gc/zero? ::complex - [x] - (let [[rx ix] (vals x)] - (and (zero? rx) (zero? ix)))) - -(defmethod gc/= [::complex ::complex] - [x y] - (let [[rx ix] (vals x) - [ry iy] (vals y)] - (and (gc/= rx ry) (gc/= ix iy)))) - -(defmethod gc/= [::pure-imaginary ::pure-imaginary] - [x y] - (gc/= (imag x) (imag y))) - -(defmethod gc/= [::complex ::pure-imaginary] - [x y] - (let [[rx ix] (vals x)] - (and (gc/zero? rx) (gc/= ix (imag y))))) - -(defmethod gc/= [::pure-imaginary ::complex] - [x y] - (let [[ry iy] (vals y)] - (and (gc/zero? ry) (gc/= (imag x) iy)))) - -(defmethod gc/= [::complex root-type] - [x y] - (let [[rx ix] (vals x)] - (and (gc/zero? ix) (gc/= rx y)))) - -(defmethod gc/= [root-type ::complex] - [x y] - (let [[ry iy] (vals y)] - (and (gc/zero? iy) (gc/= x ry)))) - -(defmethod gc/= [::pure-imaginary root-type] - [x y] - (and (gc/zero? (imag x)) (gc/zero? y))) - -(defmethod gc/= [root-type ::pure-imaginary] - [x y] - (and (gc/zero? x) (gc/zero? (imag y)))) - -; -; Addition -; -(defmethod ga/+ [::complex ::complex] - [x y] - (let [[rx ix] (vals x) - [ry iy] (vals y)] - (complex (ga/+ rx ry) (ga/+ ix iy)))) - -(defmethod ga/+ [::pure-imaginary ::pure-imaginary] - [x y] - (imaginary (ga/+ (imag x) (imag y)))) - -(defmethod ga/+ [::complex ::pure-imaginary] - [x y] - (let [[rx ix] (vals x)] - (complex rx (ga/+ ix (imag y))))) - -(defmethod ga/+ [::pure-imaginary ::complex] - [x y] - (let [[ry iy] (vals y)] - (complex ry (ga/+ (imag x) iy)))) - -(defmethod ga/+ [::complex root-type] - [x y] - (let [[rx ix] (vals x)] - (complex (ga/+ rx y) ix))) - -(defmethod ga/+ [root-type ::complex] - [x y] - (let [[ry iy] (vals y)] - (complex (ga/+ x ry) iy))) - -(defmethod ga/+ [::pure-imaginary root-type] - [x y] - (complex y (imag x))) - -(defmethod ga/+ [root-type ::pure-imaginary] - [x y] - (complex x (imag y))) - -; -; Negation -; -(defmethod ga/- ::complex - [x] - (let [[rx ix] (vals x)] - (complex (ga/- rx) (ga/- ix)))) - -(defmethod ga/- ::pure-imaginary - [x] - (imaginary (ga/- (imag x)))) - -; -; Subtraction is automatically supplied by ga/-, optimized implementations -; can be added later... -; - -; -; Multiplication -; -(defmethod ga/* [::complex ::complex] - [x y] - (let [[rx ix] (vals x) - [ry iy] (vals y)] - (complex (ga/- (ga/* rx ry) (ga/* ix iy)) - (ga/+ (ga/* rx iy) (ga/* ix ry))))) - -(defmethod ga/* [::pure-imaginary ::pure-imaginary] - [x y] - (ga/- (ga/* (imag x) (imag y)))) - -(defmethod ga/* [::complex ::pure-imaginary] - [x y] - (let [[rx ix] (vals x) - iy (imag y)] - (complex (ga/- (ga/* ix iy)) - (ga/* rx iy)))) - -(defmethod ga/* [::pure-imaginary ::complex] - [x y] - (let [ix (imag x) - [ry iy] (vals y)] - (complex (ga/- (ga/* ix iy)) - (ga/* ix ry)))) - -(defmethod ga/* [::complex root-type] - [x y] - (let [[rx ix] (vals x)] - (complex (ga/* rx y) (ga/* ix y)))) - -(defmethod ga/* [root-type ::complex] - [x y] - (let [[ry iy] (vals y)] - (complex (ga/* x ry) (ga/* x iy)))) - -(defmethod ga/* [::pure-imaginary root-type] - [x y] - (imaginary (ga/* (imag x) y))) - -(defmethod ga/* [root-type ::pure-imaginary] - [x y] - (imaginary (ga/* x (imag y)))) - -; -; Inversion -; -(ga/defmethod* ga / ::complex - [x] - (let [[rx ix] (vals x) - den ((ga/qsym ga /) (ga/+ (ga/* rx rx) (ga/* ix ix)))] - (complex (ga/* rx den) (ga/- (ga/* ix den))))) - -(ga/defmethod* ga / ::pure-imaginary - [x] - (imaginary (ga/- ((ga/qsym ga /) (imag x))))) - -; -; Division is automatically supplied by ga//, optimized implementations -; can be added later... -; - -; -; Conjugation -; -(defmethod gm/conjugate ::complex - [x] - (let [[r i] (vals x)] - (complex r (ga/- i)))) - -(defmethod gm/conjugate ::pure-imaginary - [x] - (imaginary (ga/- (imag x)))) - -; -; Absolute value -; -(defmethod gm/abs ::complex - [x] - (let [[r i] (vals x)] - (gm/sqrt (ga/+ (ga/* r r) (ga/* i i))))) - -(defmethod gm/abs ::pure-imaginary - [x] - (gm/abs (imag x))) - -; -; Square root -; -(let [one-half (/ 1 2) - one-eighth (/ 1 8)] - (defmethod gm/sqrt ::complex - [x] - (let [[r i] (vals x)] - (if (and (gc/zero? r) (gc/zero? i)) - 0 - (let [; The basic formula would say - ; abs (gm/sqrt (ga/+ (ga/* r r) (ga/* i i))) - ; p (gm/sqrt (ga/* one-half (ga/+ abs r))) - ; but the slightly more complicated one below - ; avoids overflow for large r or i. - ar (gm/abs r) - ai (gm/abs i) - r8 (ga/* one-eighth ar) - i8 (ga/* one-eighth ai) - abs (gm/sqrt (ga/+ (ga/* r8 r8) (ga/* i8 i8))) - p (ga/* 2 (gm/sqrt (ga/+ abs r8))) - q ((ga/qsym ga /) ai (ga/* 2 p)) - s (gm/sgn i)] - (if (gc/< r 0) - (complex q (ga/* s p)) - (complex p (ga/* s q)))))))) - -; -; Exponential function -; -(defmethod gm/exp ::complex - [x] - (let [[r i] (vals x) - exp-r (gm/exp r) - cos-i (gm/cos i) - sin-i (gm/sin i)] - (complex (ga/* exp-r cos-i) (ga/* exp-r sin-i)))) - -(defmethod gm/exp ::pure-imaginary - [x] - (let [i (imag x)] - (complex (gm/cos i) (gm/sin i)))) diff --git a/src/clojure/contrib/cond.clj b/src/clojure/contrib/cond.clj deleted file mode 100644 index 0ae8ca06..00000000 --- a/src/clojure/contrib/cond.clj +++ /dev/null @@ -1,34 +0,0 @@ -;; Copyright (c) Stephen C. Gilardi. 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. -;; -;; File: cond.clj -;; -;; scgilardi (gmail) -;; 2 October 2008 - -(ns #^{:author "Stephen C. Gilardi" - :doc "Extensions to the basic cond function."} - clojure.contrib.cond) - -(defmacro cond-let - "Takes a binding-form and a set of test/expr pairs. Evaluates each test - one at a time. If a test returns logical true, cond-let evaluates and - returns expr with binding-form bound to the value of test and doesn't - evaluate any of the other tests or exprs. To provide a default value - either provide a literal that evaluates to logical true and is - binding-compatible with binding-form, or use :else as the test and don't - refer to any parts of binding-form in the expr. (cond-let binding-form) - returns nil." - [bindings & clauses] - (let [binding (first bindings)] - (when-let [[test expr & more] clauses] - (if (= test :else) - expr - `(if-let [~binding ~test] - ~expr - (cond-let ~bindings ~@more)))))) diff --git a/src/clojure/contrib/condition.clj b/src/clojure/contrib/condition.clj deleted file mode 100644 index 98aa589a..00000000 --- a/src/clojure/contrib/condition.clj +++ /dev/null @@ -1,147 +0,0 @@ -;; Copyright (c) Stephen C. Gilardi. 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. -;; -;; condition.clj -;; -;; scgilardi (gmail) -;; Created 09 June 2009 - -(ns #^{:author "Stephen C. Gilardi" - :doc "Flexible raising and handling of conditions: - -Functions: - - raise: raises a condition - handler-case: dispatches raised conditions to appropriate handlers - print-stack-trace: prints abbreviated or full condition stack traces - -Data: - - A condition is a map containing values for these keys: - - - :type, a condition type specifier, typically a keyword - - :stack-trace, a stack trace to the site of the raise - - :message, a human-readable message (optional) - - :cause, a wrapped exception or condition (optional) - - other keys given as arguments to raise (optional) - -Note: requires AOT compilation. - -Based on an idea from Chouser: -http://groups.google.com/group/clojure/browse_frm/thread/da1285c538f22bb5"} - clojure.contrib.condition - (:require clojure.contrib.condition.Condition) - (:import clojure.contrib.condition.Condition - clojure.lang.IPersistentMap) - (:use (clojure.contrib - [def :only (defvar)] - [seq-utils :only (separate)]))) - -(defvar *condition* - "While a handler is running, bound to the condition being handled") - -(defvar *selector* - "While a handler is running, bound to the selector returned by the - handler-case dispatch-fn for *condition*") - -(defvar *condition-object* - "While a handler is running, bound to the Condition object whose metadata - is the condition") - -(defvar *full-stack-traces* false - "Bind to true to include clojure.{core,lang,main} frames in stack - traces") - -(defmacro raise - "Raises a condition. With no arguments, re-raises the current condition. - With one argument (a map), raises the argument. With two or more - arguments, raises a map with keys and values from the arguments." - ([] - `(throw *condition-object*)) - ([m] - `(throw (Condition. ~m))) - ([key val & keyvals] - `(raise (hash-map ~key ~val ~@keyvals)))) - -(defmacro handler-case - "Executes body in a context where raised conditions can be handled. - - dispatch-fn accepts a raised condition (a map) and returns a selector - used to choose a handler. Commonly, dispatch-fn will be :type to dispatch - on the condition's :type value. - - Handlers are forms within body: - - (handle key - ...) - - If a condition is raised, executes the body of the first handler whose - key satisfies (isa? selector key). If no handlers match, re-raises the - condition. - - While a handler is running, *condition* is bound to the condition being - handled and *selector* is bound to to the value returned by dispatch-fn - that matched the handler's key." - [dispatch-fn & body] - (let [[handlers code] - (separate #(and (list? %) (= 'handle (first %))) body)] - `(try - ~@code - (catch Condition c# - (binding [*condition-object* c# - *condition* (meta c#) - *selector* (~dispatch-fn (meta c#))] - (cond - ~@(mapcat - (fn [[_ key & body]] - `[(isa? *selector* ~key) (do ~@body)]) - handlers) - :else (raise))))))) - -(defmulti stack-trace-info - "Returns header, stack-trace, and cause info from conditions and - Throwables" - class) - -(defmethod stack-trace-info IPersistentMap - [condition] - [(format "condition: %s, %s" (:type condition) - (dissoc condition :type :stack-trace :cause)) - (:stack-trace condition) - (:cause condition)]) - -(defmethod stack-trace-info Condition - [condition] - (stack-trace-info (meta condition))) - -(defmethod stack-trace-info Throwable - [throwable] - [(str throwable) - (.getStackTrace throwable) - (.getCause throwable)]) - -(defn print-stack-trace - "Prints a stack trace for a condition or Throwable. Skips frames for - classes in clojure.{core,lang,main} unless the *full-stack-traces* is - bound to logical true" - [x] - (let [[header frames cause] (stack-trace-info x)] - (printf "%s\n" header) - (doseq [frame frames] - (let [classname (.getClassName frame)] - (if (or *full-stack-traces* - (not (re-matches - #"clojure.(?:core|lang|main).*" classname))) - (printf " at %s/%s(%s:%s)\n" - classname - (.getMethodName frame) - (.getFileName frame) - (.getLineNumber frame))))) - (when cause - (printf "caused by: ") - (recur cause)))) diff --git a/src/clojure/contrib/condition/Condition.clj b/src/clojure/contrib/condition/Condition.clj deleted file mode 100644 index 18449653..00000000 --- a/src/clojure/contrib/condition/Condition.clj +++ /dev/null @@ -1,43 +0,0 @@ -;; Copyright (c) Stephen C. Gilardi. 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. -;; -;; Condition.clj -;; -;; Used by clojure.contrib.condition to implement a "Throwable map" -;; -;; scgilardi (gmail) -;; Created 09 June 2009 - -(ns clojure.contrib.condition.Condition - (:gen-class :extends Throwable - :implements [clojure.lang.IMeta] - :state state - :init init - :post-init post-init - :constructors {[clojure.lang.IPersistentMap] - [String Throwable]})) - -(defn -init - "Constructs a Condition object with condition (a map) as its - metadata. Also initializes the superclass with the values at :message - and :cause, if any, so they are also available via .getMessage and - .getCause." - [condition] - [[(:message condition) (:cause condition)] (atom condition)]) - -(defn -post-init - "Adds :stack-trace to the condition. Drops the bottom 3 frames because - they are always the same: implementation details of Condition and raise." - [this condition] - (swap! (.state this) assoc - :stack-trace (into-array (drop 3 (.getStackTrace this))))) - -(defn -meta - "Returns this object's metadata, the condition" - [this] - @(.state this)) diff --git a/src/clojure/contrib/condition/example.clj b/src/clojure/contrib/condition/example.clj deleted file mode 100644 index 5a7d72ef..00000000 --- a/src/clojure/contrib/condition/example.clj +++ /dev/null @@ -1,66 +0,0 @@ -;; Copyright (c) Stephen C. Gilardi. 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. -;; -;; clojure.contrib.condition.example.clj -;; -;; scgilardi (gmail) -;; Created 09 June 2009 - -(ns clojure.contrib.condition.example - (:use (clojure.contrib - [condition - :only (handler-case print-stack-trace raise *condition*)]))) - -(defn func [x y] - "Raises an exception if x is negative" - (when (neg? x) - (raise :type :illegal-argument :arg 'x :value x)) - (+ x y)) - -(defn main - [] - - ;; simple handler - - (handler-case :type - (println (func 3 4)) - (println (func -5 10)) - (handle :illegal-argument - (print-stack-trace *condition*)) - (println 3)) - - ;; multiple handlers - - (handler-case :type - (println (func 4 1)) - (println (func -3 22)) - (handle :overflow - (print-stack-trace *condition*)) - (handle :illegal-argument - (print-stack-trace *condition*))) - - ;; nested handlers - - (handler-case :type - (handler-case :type - nil - nil - (println 1) - (println 2) - (println 3) - (println (func 8 2)) - (println (func -6 17)) - ;; no handler for :illegal-argument - (handle :overflow - (println "nested") - (print-stack-trace *condition*))) - (println (func 3 4)) - (println (func -5 10)) - (handle :illegal-argument - (println "outer") - (print-stack-trace *condition*)))) diff --git a/src/clojure/contrib/core.clj b/src/clojure/contrib/core.clj deleted file mode 100644 index fe6f50e9..00000000 --- a/src/clojure/contrib/core.clj +++ /dev/null @@ -1,81 +0,0 @@ -; Copyright (c) Laurent Petit and others, March 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. - -;; functions/macros variants of the ones that can be found in clojure.core - -;; note to other contrib members: feel free to add to this lib - -(ns - #^{:author "Laurent Petit (and others)" - :doc "Functions/macros variants of the ones that can be found in clojure.core - (note to other contrib members: feel free to add to this lib)"} - clojure.contrib.core - (:use clojure.contrib.def)) - -(defmacro- defnilsafe [docstring non-safe-name nil-safe-name] - `(defmacro ~nil-safe-name ~docstring - {:arglists '([~'x ~'form] [~'x ~'form ~'& ~'forms])} - ([x# form#] - `(let [~'i# ~x#] (when-not (nil? ~'i#) (~'~non-safe-name ~'i# ~form#)))) - ([x# form# & more#] - `(~'~nil-safe-name (~'~nil-safe-name ~x# ~form#) ~@more#)))) - -(defnilsafe - "Same as clojure.core/-> but returns nil as soon as the threaded value is nil itself (thus short-circuiting any pending computation). - Examples : - (-?> \"foo\" .toUpperCase (.substring 1)) returns \"OO\" - (-?> nil .toUpperCase (.substring 1)) returns nil - " - -> -?>) - -(defnilsafe - "Same as clojure.core/.. but returns nil as soon as the threaded value is nil itself (thus short-circuiting any pending computation). - Examples : - (.?. \"foo\" .toUpperCase (.substring 1)) returns \"OO\" - (.?. nil .toUpperCase (.substring 1)) returns nil - " - .. .?.) - -;; ---------------------------------------------------------------------- -;; scgilardi at gmail - -(defn dissoc-in - "Dissociates an entry from a nested associative structure returning a new - nested structure. keys is a sequence of keys. Any empty maps that result - will not be present in the new structure." - [m [k & ks :as keys]] - (if ks - (if-let [nextmap (get m k)] - (let [newmap (dissoc-in nextmap ks)] - (if (seq newmap) - (assoc m k newmap) - (dissoc m k))) - m) - (dissoc m k))) - -(defn new-by-name - "Constructs a Java object whose class is specified by a String." - [class-name & args] - (clojure.lang.Reflector/invokeConstructor - (clojure.lang.RT/classForName class-name) - (into-array Object args))) - -(defn seqable? - "Returns true if (seq x) will succeed, false otherwise." - [x] - (or (seq? x) - (instance? clojure.lang.Seqable x) - (nil? x) - (instance? Iterable x) - (-> x .getClass .isArray) - (string? x) - (instance? java.util.Map x))) - -;; ---------------------------------------------------------------------- diff --git a/src/clojure/contrib/core/tests.clj b/src/clojure/contrib/core/tests.clj deleted file mode 100644 index d2e0d50d..00000000 --- a/src/clojure/contrib/core/tests.clj +++ /dev/null @@ -1,36 +0,0 @@ -; Copyright (c) Laurent Petit, March 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. - -;; test namespace for clojure.contrib.core - -;; note to other contrib members: feel free to add to this lib - -(ns clojure.contrib.core.tests - (:use clojure.test) - (:use clojure.contrib.core)) - -(deftest test-classic-versions - (testing "Classic -> throws NPE if passed nil" - (is (thrown? NullPointerException (-> nil .toString))) - (is (thrown? NullPointerException (-> "foo" seq next next next .toString)))) - (testing "Classic .. throws NPE if one of the intermediate threaded values is nil" - (is (thrown? NullPointerException (.. nil toString))) - (is (thrown? NullPointerException (.. [nil] (get 0) toString))))) - -(deftest test-new-versions - (testing "Version -?> returns nil if passed nil" - (is (nil? (-?> nil .toString))) - (is (nil? (-?> "foo" seq next next next .toString)))) - (testing "Version -?> works well for some basic use cases" - (is (= (list \O \O) (-?> "foo" .toUpperCase rest)))) - (testing "Version .?. returns nil if one of the intermediate threaded values is nil" - (is (nil? (.?. nil toString))) - (is (nil? (.?. [nil] (get 0) toString))))) -
\ No newline at end of file diff --git a/src/clojure/contrib/dataflow.clj b/src/clojure/contrib/dataflow.clj deleted file mode 100644 index 894942be..00000000 --- a/src/clojure/contrib/dataflow.clj +++ /dev/null @@ -1,508 +0,0 @@ -;; Copyright (c) Jeffrey Straszheim. 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. -;; -;; dataflow.clj -;; -;; A Library to Support a Dataflow Model of State -;; -;; straszheimjeffrey (gmail) -;; Created 10 March 2009 - - -(ns - #^{:author "Jeffrey Straszheim", - :doc "A library to support a dataflow model of state"} - clojure.contrib.dataflow - (:use [clojure.set :only (union intersection difference)]) - (:use [clojure.contrib.graph :only (directed-graph - reverse-graph - dependency-list - get-neighbors)]) - (:use [clojure.walk :only (postwalk)]) - (:use [clojure.contrib.except :only (throwf)])) - - -;;; Chief Data Structures - - -;; Source Cell - -; The data of a source cell is directly set by a calling function. It -; never depends on other cells. - -(defstruct source-cell - :name ; The name, a symbol - :value ; Its value, a Ref - :cell-type) ; Should be ::source-cell - -;; Cell - -; A standard cell that computes its value from other cells. - -(defstruct standard-cell - :name ; The name, a symbol - :value ; Its value, a Ref - :dependents ; The names of cells on which this depends, a collection - :fun ; A closure that computes the value, given an environment - :display ; The original expression for display - :cell-type) ; Should be ::cell - -(derive ::cell ::dependent-cell) ; A cell that has a dependents field - -;; Validator - -; A cell that has no value, but can throw an exception when run - -(defstruct validator-cell - :name ; Always ::validator - :dependents ; The names of cells on which this depends, a collection - :fun ; A clojure that can throw an exception - :display ; The original exprssion for display - :cell-type) ; Should be ::validator-cell - -(derive ::validator-cell ::dependent-cell) - - -;; A sentinal value - -(def *empty-value* (java.lang.Object.)) - - -;; Dataflow - -; A collection of cells and dependency information - -(defstruct dataflow - :cells ; A set of all cells - :cells-map ; A map of cell names (symbols) to collections of cells - :fore-graph ; The inverse of the dependency graph, nodes are cells - :topological) ; A vector of sets of independent nodes -- orders the computation - - -;;; Environment Access - -(defn get-cells - "Get all the cells named by name" - [df name] - ((:cells-map @df) name)) - -(defn get-cell - "Get the single cell named by name" - [df name] - (let [cells (get-cells df name)] - (cond - (= (count cells) 1) (first cells) - (> (count cells) 1) (throwf Exception "Cell %s has multiple instances" name) - :otherwise (throwf Exception "Cell %s is undefined" name)))) - -(defn source-cell? - "Is this cell a source cell?" - [cell] - (isa? (:cell-type cell) ::source-cell)) - -(defn get-source-cells - "Returns a collection of source cells from the dataflow" - [df] - (for [cell (:cells @df) - :when (source-cell? cell)] - cell)) - -(defn get-value - "Gets a value from the df matching the passed symbol. - Signals an error if the name is not present, or if it not a single - value." - [df name] - (let [cell (get-cell df name) - result @(:value cell)] - (do (when (= *empty-value* result) - (throwf Exception "Cell named %s empty" name)) - result))) - -(defn get-values - "Gets a collection of values from the df by name" - [df name] - (let [cells (get-cells df name) - results (map #(-> % :value deref) cells)] - (do - (when (some #(= % *empty-value*) results) - (throwf Exception "At least one empty cell named %s found" name)) - results))) - -(defn get-old-value - "Looks up an old value" - [df env name] - (if (contains? env name) - (env name) - (get-value df name))) - -(defn get-value-from-cell - "Given a cell, get its value" - [cell] - (-> cell :value deref)) - -;;; Build Dataflow Structure - -(defn- build-cells-map - "Given a collection of cells, build a name->cells-collection map - from it." - [cs] - (let [step (fn [m c] - (let [n (:name c) - o (get m n #{}) - s (conj o c)] - (assoc m n s)))] - (reduce step {} cs))) - -(defn- build-back-graph - "Builds the backward dependency graph from the cells map. Each - node of the graph is a cell." - [cells cells-map] - (let [step (fn [n] - (apply union (for [dep-name (:dependents n)] - (cells-map dep-name)))) - neighbors (zipmap cells (map step cells))] - (struct-map directed-graph - :nodes cells - :neighbors neighbors))) - -(defn- build-dataflow* - "Builds the dataflow structure" - [cs] - (let [cells (set cs) - cells-map (build-cells-map cs) - back-graph (build-back-graph cells cells-map) - fore-graph (reverse-graph back-graph)] - (struct-map dataflow - :cells cells - :cells-map cells-map - :fore-graph fore-graph - :topological (dependency-list back-graph)))) - -(def initialize) - -(defn build-dataflow - "Given a collection of cells, build and return a dataflow object" - [cs] - (dosync - (let [df (ref (build-dataflow* cs))] - (initialize df) - df))) - - -;;; Displaying a dataflow - -(defn print-dataflow - "Prints a dataflow, one cell per line" - [df] - (println) - (let [f (fn [cell] (-> cell :name str))] - (doseq [cell (sort-by f (:cells @df))] - (prn cell)))) - - -;;; Modifying a Dataflow - -(defn add-cells - "Given a collection of cells, add them to the dataflow." - [df cells] - (dosync - (let [new-cells (union (set cells) (:cells @df))] - (ref-set df (build-dataflow* new-cells)) - (initialize df)))) - -(defn remove-cells - "Given a collection of cells, remove them from the dataflow." - [df cells] - (dosync - (let [new-cells (difference (:cells @df) (set cells))] - (ref-set df (build-dataflow* new-cells)) - (initialize df)))) - - -;;; Cell building - -(def *meta* {:type ::dataflow-cell}) - -(defn build-source-cell - "Builds a source cell" - [name init] - (with-meta (struct source-cell name (ref init) ::source-cell) - *meta*)) - -(defn- is-col-var? - [symb] - (let [name (name symb)] - (and (= \? (first name)) - (= \* (second name))))) - -(defn- is-old-var? - [symb] - (let [name (name symb)] - (and (= \? (first name)) - (= \- (second name))))) - -(defn- is-var? - [symb] - (let [name (name symb)] - (and (= \? (first name)) - (-> symb is-col-var? not) - (-> symb is-old-var? not)))) - -(defn- cell-name - [symb] - `(quote ~(cond (is-var? symb) (-> symb name (.substring 1) symbol) - (or (is-col-var? symb) - (is-old-var? symb)) (-> symb name (.substring 2) symbol)))) - -(defn- replace-symbol - "Walk the from replacing the ?X forms with the needed calls" - [dfs ov form] - (cond - (-> form symbol? not) form - (is-var? form) `(get-value ~dfs ~(cell-name form)) - (is-col-var? form) `(get-values ~dfs ~(cell-name form)) - (is-old-var? form) `(get-old-value ~dfs ~ov ~(cell-name form)) - :otherwise form)) - -(defn- build-fun - "Build the closure needed to compute a cell" - [form] - (let [dfs (gensym "df_") - ov (gensym "old_")] - `(fn [~dfs ~ov] ~(postwalk (partial replace-symbol dfs ov) form)))) - -(defn- get-deps - "Get the names of the dependent cells" - [form] - (let [step (fn [f] - (cond - (coll? f) (apply union f) - (-> f symbol? not) nil - (is-var? f) #{(cell-name f)} - (is-col-var? f) #{(cell-name f)} - (is-old-var? f) #{(cell-name f)} - :otherwise nil))] - (postwalk step form))) - -(defn build-standard-cell - "Builds a standard cell" - [name deps fun expr] - (with-meta (struct standard-cell name (ref *empty-value*) deps fun expr ::cell) - *meta*)) - -(defn build-validator-cell - "Builds a validator cell" - [deps fun expr] - (with-meta (struct validator-cell ::validator deps fun expr ::validator-cell) - *meta*)) - -(defmacro cell - "Build a standard cell, like this: - - (cell fred - (* ?mary ?joe)) - - Which creates a cell named fred that is the product of a cell mary and cell joe - - Or: - - (cell joe - (apply * ?*sally)) - - Which creates a cell that applies * to the collection of all cells named sally - - Or: - - (cell :source fred 0) - - Which builds a source cell fred with initial value 0 - - Or: - - (cell :validator (when (< ?fred ?sally) - (throwf \"%s must be greater than %s\" ?fred ?sally)) - - Which will perform the validation" - [type & data] - (cond - (symbol? type) (let [name type ; No type for standard cell - expr (first data) ; we ignore extra data! - deps (get-deps expr) - fun (build-fun expr)] - `(build-standard-cell '~name ~deps ~fun '~expr)) - (= type :source) (let [[name init] data] - `(build-source-cell '~name ~init)) - (= type :validator) (let [[expr] data - deps (get-deps expr) - fun (build-fun expr)] - `(build-validator-cell ~deps ~fun '~expr)))) - - -;;; Cell Display - -(defmulti display-cell - "A 'readable' form of the cell" - :cell-type) - -(defmethod display-cell ::source-cell - [cell] - (list 'cell :source (:name cell) (-> cell :value deref))) - -(defmethod display-cell ::cell - [cell] - (list 'cell (:name cell) (:display cell) (-> cell :value deref))) - -(defmethod display-cell ::validator-cell - [cell] - (list 'cell :validator (:display cell))) - -(defmethod print-method ::dataflow-cell - [f #^Writer w] - (binding [*out* w] - (pr (display-cell f)))) - - -;;; Evaluation - -(defmulti eval-cell - "Evaluate a dataflow cell. Return [changed, old val]" - (fn [df data old cell] (:cell-type cell))) - -(defmethod eval-cell ::source-cell - [df data old cell] - (let [name (:name cell) - val (:value cell) - ov @val] - (if (contains? data name) - (let [new-val (data name)] - (if (not= ov new-val) - (do (ref-set val new-val) - [true ov]) - [false ov])) - [false ov]))) - -(defmethod eval-cell ::cell - [df data old cell] - (let [val (:value cell) - old-val @val - new-val ((:fun cell) df old)] - (if (not= old-val new-val) - (do (ref-set val new-val) - [true old-val]) - [false old-val]))) - -(defmethod eval-cell ::validator-cell - [df data old cell] - (do ((:fun cell) df old) - [false nil])) - -(defn- perform-flow - "Evaluate the needed cells (a set) from the given dataflow. Data is - a name-value mapping of new values for the source cells" - [df data needed] - (loop [needed needed - tops (:topological @df) - old {}] - (let [now (first tops) ; Now is a set of nodes - new-tops (next tops)] - (when (and (-> needed empty? not) - (-> now empty? not)) - (let [step (fn [[needed old] cell] - (let [[changed ov] (try - (eval-cell df data old cell) - (catch Exception e - (throw (Exception. (str cell) e)))) - nn (disj needed cell)] - (if changed - [(union nn (get-neighbors (:fore-graph @df) cell)) - (assoc old (:name cell) ov)] - [nn old]))) - [new-needed new-old] (reduce step - [needed old] - (intersection now needed))] - (recur new-needed new-tops new-old)))))) - -(defn- validate-update - "Ensure that all the updated cells are source cells" - [df names] - (let [scns (set (map :name (get-source-cells df)))] - (doseq [name names] - (when (-> name scns not) - (throwf Exception "Cell %n is not a source cell" name))))) - -(defn update-values - "Given a dataflow, and a map of name-value pairs, update the - dataflow by binding the new values. Each name must be of a source - cell" - [df data] - (dosync - (validate-update df (keys data)) - (let [needed (apply union (for [name (keys data)] - (set ((:cells-map @df) name))))] - (perform-flow df data needed)))) - -(defn- initialize - "Apply all the current source cell values. Useful for a new - dataflow, or one that has been updated with new cells" - [df] - (let [needed (:cells @df) - fg (:fore-graph @df)] - (perform-flow df {} needed))) - - -;;; Watchers - -(defn add-cell-watcher - "Adds a watcher to a cell to respond to changes of value. The is a - function of 4 values: a key, the cell, its old value, its new - value. This is implemented using Clojure's add-watch to the - underlying ref, and shared its sematics" - [cell key fun] - (let [val (:value cell)] - (add-watch val key (fn [key _ old-v new-v] - (fun key cell old-v new-v))))) - - -(comment - - (def df - (build-dataflow - [(cell :source fred 1) - (cell :source mary 0) - (cell greg (+ ?fred ?mary)) - (cell joan (+ ?fred ?mary)) - (cell joan (* ?fred ?mary)) - (cell sally (apply + ?*joan)) - (cell :validator (when (number? ?-greg) - (when (<= ?greg ?-greg) - (throwf Exception "Non monotonic"))))])) - - (do (println) - (print-dataflow df)) - - (add-cell-watcher (get-cell df 'sally) - nil - (fn [key cell o n] - (printf "sally changed from %s to %s\n" o n))) - - (update-values df {'fred 1 'mary 1}) - (update-values df {'fred 5 'mary 1}) - (update-values df {'fred 0 'mary 0}) - - (get-value df 'fred) - (get-values df 'joan) - (get-value df 'sally) - (get-value df 'greg) - - (use :reload 'clojure.contrib.dataflow) - (use 'clojure.stacktrace) (e) - (use 'clojure.contrib.trace) -) - - -;; End of file diff --git a/src/clojure/contrib/datalog.clj b/src/clojure/contrib/datalog.clj deleted file mode 100644 index 93e132de..00000000 --- a/src/clojure/contrib/datalog.clj +++ /dev/null @@ -1,64 +0,0 @@ -;; Copyright (c) Jeffrey Straszheim. 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. -;; -;; datalog.clj -;; -;; A Clojure implementation of Datalog -;; -;; straszheimjeffrey (gmail) -;; Created 2 March 2009 - - -;;; Please see the example.clj file in the datalog folder - - -(ns - #^{:author "Jeffrey Straszheim", - :doc "A Clojure implementation of Datalog"} - clojure.contrib.datalog - (:use clojure.contrib.datalog.rules - clojure.contrib.datalog.softstrat - clojure.contrib.datalog.database) - (:use [clojure.set :only (intersection)] - [clojure.contrib.except :only (throwf)])) - -(defstruct work-plan - :work-plan ; The underlying structure - :rules ; The original rules - :query ; The original query - :work-plan-type) ; The type of plan - -(defn- validate-work-plan - "Ensure any top level semantics are not violated" - [work-plan database] - (let [common-relations (-> work-plan :rules (intersection (-> database keys set)))] - (when (-> common-relations - empty? - not) - (throwf "The rules and database define the same relation(s): %s" common-relations)))) - ; More will follow - -(defn build-work-plan - "Given a list of rules and a query, build a work plan that can be - used to execute the query." - [rules query] - (struct-map work-plan - :work-plan (build-soft-strat-work-plan rules query) - :rules rules - :query query - :work-plan-type ::soft-stratified)) - -(defn run-work-plan - "Given a work plan, a database, and some query bindings, run the - work plan and return the results." - [work-plan database query-bindings] - (validate-work-plan work-plan database) - (evaluate-soft-work-set (:work-plan work-plan) database query-bindings)) - - -;; End of file diff --git a/src/clojure/contrib/datalog/database.clj b/src/clojure/contrib/datalog/database.clj deleted file mode 100644 index aba41df9..00000000 --- a/src/clojure/contrib/datalog/database.clj +++ /dev/null @@ -1,287 +0,0 @@ -;; Copyright (c) Jeffrey Straszheim. 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. -;; -;; database.clj -;; -;; A Clojure implementation of Datalog -- Support for in-memory database -;; -;; straszheimjeffrey (gmail) -;; Created 21 Feburary 2009 - - -(ns clojure.contrib.datalog.database - (:use clojure.contrib.datalog.util) - (:use clojure.contrib.def) - (:use [clojure.set :only (union intersection difference)]) - (:use [clojure.contrib.except :only (throwf)])) - - -(defstruct relation - :schema ; A set of key names - :data ; A set of tuples - :indexes) ; A map key names to indexes (in turn a map of value to tuples) - - -;;; DDL - -(defmethod print-method ::datalog-database - [db #^Writer writer] - (binding [*out* writer] - (do - (println "(datalog-database") - (println "{") - (doseq [key (keys db)] - (println) - (println key) - (print-method (db key) writer)) - (println "})")))) - -(defn datalog-database - [rels] - (with-meta rels {:type ::datalog-database})) - -(def empty-database (datalog-database {})) - -(defmethod print-method ::datalog-relation - [rel #^Writer writer] - (binding [*out* writer] - (do - (println "(datalog-relation") - (println " ;; Schema") - (println " " (:schema rel)) - (println) - (println " ;; Data") - (println " #{") - (doseq [tuple (:data rel)] - (println " " tuple)) - (println " }") - (println) - (println " ;; Indexes") - (println " {") - (doseq [key (-> rel :indexes keys)] - (println " " key) - (println " {") - (doseq [val (keys ((:indexes rel) key))] - (println " " val) - (println " " (get-in rel [:indexes key val]))) - (println " }")) - (println " })")))) - -(defn datalog-relation - "Creates a relation" - [schema data indexes] - (with-meta (struct relation schema data indexes) {:type ::datalog-relation})) - -(defn add-relation - "Adds a relation to the database" - [db name keys] - (assoc db name (datalog-relation (set keys) #{} {}))) - -(defn add-index - "Adds an index to an empty relation named name" - [db name key] - (assert (empty? (:data (db name)))) - (let [rel (db name) - inx (assoc (:indexes rel) key {})] - (assoc db name (datalog-relation (:schema rel) - (:data rel) - inx)))) - -(defn ensure-relation - "If the database lacks the named relation, add it" - [db name keys indexes] - (if-let [rel (db name)] - (do - (assert (= (:schema rel) (set keys))) - db) - (let [db1 (add-relation db name keys)] - (reduce (fn [db key] (add-index db name key)) - db1 - indexes)))) - - -(defmacro make-database - "Makes a database, like this - (make-database - (relation :fred [:mary :sue]) - (index :fred :mary) - (relation :sally [:jen :becky]) - (index :sally :jen) - (index :sally :becky))" - [& commands] - (let [wrapper (fn [cur new] - (let [cmd (first new) - body (next new)] - (assert (= 2 (count body))) - (cond - (= cmd 'relation) - `(add-relation ~cur ~(first body) ~(fnext body)) - (= cmd 'index) - `(add-index ~cur ~(first body) ~(fnext body)) - :otherwise (throwf "%s not recognized" new))))] - (reduce wrapper `empty-database commands))) - -(defn get-relation - "Get a relation object by name" - [db rel-name] - (db rel-name)) - -(defn replace-relation - "Add or replace a fully constructed relation object to the database." - [db rel-name rel] - (assoc db rel-name rel)) - - -;;; DML - - -(defn database-counts - "Returns a map with the count of elements in each relation." - [db] - (map-values #(-> % :data count) db)) - -(defn- modify-indexes - "Perform f on the indexed tuple-set. f should take a set and tuple, - and return the new set." - [idxs tuple f] - (into {} (for [ik (keys idxs)] - (let [im (idxs ik) - iv (tuple ik) - os (get im iv #{}) - ns (f os tuple)] - [ik (if (empty? ns) - (dissoc im iv) - (assoc im iv (f os tuple)))])))) - -(defn- add-to-indexes - "Adds the tuple to the appropriate keys in the index map" - [idxs tuple] - (modify-indexes idxs tuple conj)) - -(defn- remove-from-indexes - "Removes the tuple from the appropriate keys in the index map" - [idxs tuple] - (modify-indexes idxs tuple disj)) - -(defn add-tuple - "Two forms: - - [db relation-name tuple] adds tuple to the named relation. Returns - the new database. - - [rel tuple] adds to the relation object. Returns the new relation." - ([db rel-name tuple] - (assert (= (-> tuple keys set) (-> rel-name db :schema))) - (assoc db rel-name (add-tuple (db rel-name) tuple))) - ([rel tuple] - (let [data (:data rel) - new-data (conj data tuple)] - (if (identical? data new-data) ; optimization hack! - rel - (let [idxs (add-to-indexes (:indexes rel) tuple)] - (assoc rel :data new-data :indexes idxs)))))) - -(defn remove-tuple - "Two forms: - - [db relation-name tuple] removes the tuple from the named relation, - returns a new database. - - [rel tuple] removes the tuple from the relation. Returns the new - relation." - ([db rel-name tuple] (assoc db rel-name (remove-tuple (db rel-name) tuple))) - ([rel tuple] - (let [data (:data rel) - new-data (disj data tuple)] - (if (identical? data new-data) - rel - (let [idxs (remove-from-indexes (:indexes rel) tuple)] - (assoc rel :data new-data :indexes idxs)))))) - -(defn add-tuples - "Adds a collection of tuples to the db, as - (add-tuples db - [:rel-name :key-1 1 :key-2 2] - [:rel-name :key-1 2 :key-2 3])" - [db & tupls] - (reduce #(add-tuple %1 (first %2) (apply hash-map (next %2))) db tupls)) - -(defn- find-indexes - "Given a map of indexes and a partial tuple, return the sets of full tuples" - [idxs pt] - (if (empty? idxs) - nil - (filter identity (for [key (keys pt)] - (if-let [idx-map (idxs key)] - (get idx-map (pt key) #{}) - nil))))) - -(defn- match? - "Is m2 contained in m1?" - [m1 m2] - (let [compare (fn [key] - (and (contains? m1 key) - (= (m1 key) (m2 key))))] - (every? compare (keys m2)))) - -(defn- scan-space - "Computes a stream of tuples from relation rn matching partial tuple (pt) - and applies fun to each" - [fun db rn pt] - (let [rel (db rn) - idxs (find-indexes (:indexes rel) pt) - space (if (empty? idxs) - (:data rel) ; table scan :( - (reduce intersection idxs))] - (trace-datalog (when (empty? idxs) - (println (format "Table scan of %s: %s rows!!!!!" - rn - (count space))))) - (fun #(match? % pt) space))) - -(defn select - "finds all matching tuples to the partial tuple (pt) in the relation named (rn)" - [db rn pt] - (scan-space filter db rn pt)) - -(defn any-match? - "Finds if there are any matching records for the partial tuple" - [db rn pt] - (if (= (-> pt keys set) (:schema (db rn))) - (contains? (:data (db rn)) pt) - (scan-space some db rn pt))) - - -;;; Merge - -(defn merge-indexes - [idx1 idx2] - (merge-with (fn [h1 h2] (merge-with union h1 h2)) idx1 idx2)) - -(defn merge-relations - "Merges two relations" - [r1 r2] - (assert (= (:schema r1) (:schema r2))) - (let [merged-indexes (merge-indexes (:indexes r1) - (:indexes r2)) - merged-data (union (:data r1) - (:data r2))] - (assoc r1 :data merged-data :indexes merged-indexes))) - -(defn database-merge - "Merges databases together" - [dbs] - (apply merge-with merge-relations dbs)) - -(defn database-merge-parallel - "Merges databases together in parallel" - [dbs] - (preduce merge-relations dbs)) - - -;; End of file diff --git a/src/clojure/contrib/datalog/example.clj b/src/clojure/contrib/datalog/example.clj deleted file mode 100644 index 88fcf961..00000000 --- a/src/clojure/contrib/datalog/example.clj +++ /dev/null @@ -1,116 +0,0 @@ -;; Copyright (c) Jeffrey Straszheim. 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. -;; -;; example.clj -;; -;; A Clojure implementation of Datalog - Example -;; -;; straszheimjeffrey (gmail) -;; Created 2 March 2009 - - -(ns clojure.contrib.datalog.example - (:use [clojure.contrib.datalog :only (build-work-plan run-work-plan)] - [clojure.contrib.datalog.rules :only (<- ?- rules-set)] - [clojure.contrib.datalog.database :only (make-database add-tuples)] - [clojure.contrib.datalog.util :only (*trace-datalog*)])) - - - - -(def db-base - (make-database - (relation :employee [:id :name :position]) - (index :employee :name) - - (relation :boss [:employee-id :boss-id]) - (index :boss :employee-id) - - (relation :can-do-job [:position :job]) - (index :can-do-job :position) - - (relation :job-replacement [:job :can-be-done-by]) - ;(index :job-replacement :can-be-done-by) - - (relation :job-exceptions [:id :job]))) - -(def db - (add-tuples db-base - [:employee :id 1 :name "Bob" :position :boss] - [:employee :id 2 :name "Mary" :position :chief-accountant] - [:employee :id 3 :name "John" :position :accountant] - [:employee :id 4 :name "Sameer" :position :chief-programmer] - [:employee :id 5 :name "Lilian" :position :programmer] - [:employee :id 6 :name "Li" :position :technician] - [:employee :id 7 :name "Fred" :position :sales] - [:employee :id 8 :name "Brenda" :position :sales] - [:employee :id 9 :name "Miki" :position :project-management] - [:employee :id 10 :name "Albert" :position :technician] - - [:boss :employee-id 2 :boss-id 1] - [:boss :employee-id 3 :boss-id 2] - [:boss :employee-id 4 :boss-id 1] - [:boss :employee-id 5 :boss-id 4] - [:boss :employee-id 6 :boss-id 4] - [:boss :employee-id 7 :boss-id 1] - [:boss :employee-id 8 :boss-id 7] - [:boss :employee-id 9 :boss-id 1] - [:boss :employee-id 10 :boss-id 6] - - [:can-do-job :position :boss :job :management] - [:can-do-job :position :accountant :job :accounting] - [:can-do-job :position :chief-accountant :job :accounting] - [:can-do-job :position :programmer :job :programming] - [:can-do-job :position :chief-programmer :job :programming] - [:can-do-job :position :technician :job :server-support] - [:can-do-job :position :sales :job :sales] - [:can-do-job :position :project-management :job :project-management] - - [:job-replacement :job :pc-support :can-be-done-by :server-support] - [:job-replacement :job :pc-support :can-be-done-by :programming] - [:job-replacement :job :payroll :can-be-done-by :accounting] - - [:job-exceptions :id 4 :job :pc-support])) - -(def rules - (rules-set - (<- (:works-for :employee ?x :boss ?y) (:boss :employee-id ?e-id :boss-id ?b-id) - (:employee :id ?e-id :name ?x) - (:employee :id ?b-id :name ?y)) - (<- (:works-for :employee ?x :boss ?y) (:works-for :employee ?x :boss ?z) - (:works-for :employee ?z :boss ?y)) - (<- (:employee-job* :employee ?x :job ?y) (:employee :name ?x :position ?pos) - (:can-do-job :position ?pos :job ?y)) - (<- (:employee-job* :employee ?x :job ?y) (:job-replacement :job ?y :can-be-done-by ?z) - (:employee-job* :employee ?x :job ?z)) - (<- (:employee-job* :employee ?x :job ?y) (:can-do-job :job ?y) - (:employee :name ?x :position ?z) - (if = ?z :boss)) - (<- (:employee-job :employee ?x :job ?y) (:employee-job* :employee ?x :job ?y) - (:employee :id ?id :name ?x) - (not! :job-exceptions :id ?id :job ?y)) - (<- (:bj :name ?x :boss ?y) (:works-for :employee ?x :boss ?y) - (not! :employee-job :employee ?y :job :pc-support)))) - - - -(def wp-1 (build-work-plan rules (?- :works-for :employee '??name :boss ?x))) -(run-work-plan wp-1 db {'??name "Albert"}) - -(def wp-2 (build-work-plan rules (?- :employee-job :employee '??name :job ?x))) -(binding [*trace-datalog* true] - (run-work-plan wp-2 db {'??name "Li"})) - -(def wp-3 (build-work-plan rules (?- :bj :name '??name :boss ?x))) -(run-work-plan wp-3 db {'??name "Albert"}) - -(def wp-4 (build-work-plan rules (?- :works-for :employee ?x :boss ?y))) -(run-work-plan wp-4 db {}) - - -;; End of file diff --git a/src/clojure/contrib/datalog/literals.clj b/src/clojure/contrib/datalog/literals.clj deleted file mode 100644 index 12605160..00000000 --- a/src/clojure/contrib/datalog/literals.clj +++ /dev/null @@ -1,414 +0,0 @@ -;; Copyright (c) Jeffrey Straszheim. 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. -;; -;; literals.clj -;; -;; A Clojure implementation of Datalog -- Literals -;; -;; straszheimjeffrey (gmail) -;; Created 25 Feburary 2009 - - -(ns clojure.contrib.datalog.literals - (:use clojure.contrib.datalog.util) - (:use clojure.contrib.datalog.database) - (:use [clojure.set :only (intersection)]) - (:use [clojure.contrib.set :only (subset?)]) - (:use [clojure.contrib.seq-utils :only (flatten)])) - - -;;; Type Definitions - -(defstruct atomic-literal - :predicate ; The predicate name - :term-bindings ; A map of column names to bindings - :literal-type) ; ::literal or ::negated - -(derive ::negated ::literal) - -(defstruct conditional-literal - :fun ; The fun to call - :symbol ; The fun symbol (for display) - :terms ; The formal arguments - :literal-type) ; ::conditional - - -;;; Basics - - -(defmulti literal-predicate - "Return the predicate/relation this conditional operates over" - :literal-type) - -(defmulti literal-columns - "Return the column names this applies to" - :literal-type) - -(defmulti literal-vars - "Returns the logic vars used by this literal" - :literal-type) - -(defmulti positive-vars - "Returns the logic vars used in a positive position" - :literal-type) - -(defmulti negative-vars - "Returns the logic vars used in a negative position" - :literal-type) - -(defmethod literal-predicate ::literal - [l] - (:predicate l)) - -(defmethod literal-predicate ::conditional - [l] - nil) - -(defmethod literal-columns ::literal - [l] - (-> l :term-bindings keys set)) - -(defmethod literal-columns ::conditional - [l] - nil) - -(defmethod literal-vars ::literal - [l] - (set (filter is-var? (-> l :term-bindings vals)))) - -(defmethod literal-vars ::conditional - [l] - (set (filter is-var? (:terms l)))) - -(defmethod positive-vars ::literal - [l] - (literal-vars l)) - -(defmethod positive-vars ::negated - [l] - nil) - -(defmethod positive-vars ::conditional - [l] - nil) - -(defmethod negative-vars ::literal - [l] - nil) - -(defmethod negative-vars ::negated - [l] - (literal-vars l)) - -(defmethod negative-vars ::conditional - [l] - (literal-vars l)) - -(defn negated? - "Is this literal a negated literal?" - [l] - (= (:literal-type l) ::negated)) - -(defn positive? - "Is this a positive literal?" - [l] - (= (:literal-type l) ::literal)) - - -;;; Building Literals - -(def negation-symbol 'not!) -(def conditional-symbol 'if) - -(defmulti build-literal - "(Returns an unevaluated expression (to be used in macros) of a - literal." - first) - -(defn build-atom - "Returns an unevaluated expression (to be used in a macro) of an - atom." - [f type] - (let [p (first f) - ts (map #(if (is-var? %) `(quote ~%) %) (next f)) - b (if (seq ts) (apply assoc {} ts) nil)] - `(struct atomic-literal ~p ~b ~type))) - -(defmethod build-literal :default - [f] - (build-atom f ::literal)) - -(defmethod build-literal negation-symbol - [f] - (build-atom (rest f) ::negated)) - -(defmethod build-literal conditional-symbol - [f] - (let [symbol (fnext f) - terms (nnext f) - fun `(fn [binds#] (apply ~symbol binds#))] - `(struct conditional-literal - ~fun - '~symbol - '~terms - ::conditional))) - - -;;; Display - -(defmulti display-literal - "Converts a struct representing a literal to a normal list" - :literal-type) - -(defn- display - [l] - (conj (-> l :term-bindings list* flatten) (literal-predicate l))) - -(defmethod display-literal ::literal - [l] - (display l)) - -(defmethod display-literal ::negated - [l] - (conj (display l) negation-symbol)) - -(defmethod display-literal ::conditional - [l] - (list* conditional-symbol (:symbol l) (:terms l))) - - -;;; Sip computation - -(defmulti get-vs-from-cs - "From a set of columns, return the vars" - :literal-type) - -(defmethod get-vs-from-cs ::literal - [l bound] - (set (filter is-var? - (vals (select-keys (:term-bindings l) - bound))))) - -(defmethod get-vs-from-cs ::conditional - [l bound] - nil) - - -(defmulti get-cs-from-vs - "From a set of vars, get the columns" - :literal-type) - -(defmethod get-cs-from-vs ::literal - [l bound] - (reduce conj - #{} - (remove nil? - (map (fn [[k v]] (if (bound v) k nil)) - (:term-bindings l))))) - -(defmethod get-cs-from-vs ::conditional - [l bound] - nil) - - -(defmulti get-self-bound-cs - "Get the columns that are bound withing the literal." - :literal-type) - -(defmethod get-self-bound-cs ::literal - [l] - (reduce conj - #{} - (remove nil? - (map (fn [[k v]] (if (not (is-var? v)) k nil)) - (:term-bindings l))))) - -(defmethod get-self-bound-cs ::conditional - [l] - nil) - - -(defmulti literal-appropriate? - "When passed a set of bound vars, determines if this literal can be - used during this point of a SIP computation." - (fn [b l] (:literal-type l))) - -(defmethod literal-appropriate? ::literal - [bound l] - (not (empty? (intersection (literal-vars l) bound)))) - -(defmethod literal-appropriate? ::negated - [bound l] - (subset? (literal-vars l) bound)) - -(defmethod literal-appropriate? ::conditional - [bound l] - (subset? (literal-vars l) bound)) - - -(defmulti adorned-literal - "When passed a set of bound columns, returns the adorned literal" - (fn [l b] (:literal-type l))) - -(defmethod adorned-literal ::literal - [l bound] - (let [pred (literal-predicate l) - bnds (intersection (literal-columns l) bound)] - (if (empty? bound) - l - (assoc l :predicate {:pred pred :bound bnds})))) - -(defmethod adorned-literal ::conditional - [l bound] - l) - - -(defn get-adorned-bindings - "Get the bindings from this adorned literal." - [pred] - (:bound pred)) - -(defn get-base-predicate - "Get the base predicate from this predicate." - [pred] - (if (map? pred) - (:pred pred) - pred)) - - -;;; Magic Stuff - -(defn magic-literal - "Create a magic version of this adorned predicate." - [l] - (assert (-> l :literal-type (isa? ::literal))) - (let [pred (literal-predicate l) - pred-map (if (map? pred) pred {:pred pred}) - bound (get-adorned-bindings pred) - ntb (select-keys (:term-bindings l) bound)] - (assoc l :predicate (assoc pred-map :magic true) :term-bindings ntb :literal-type ::literal))) - -(defn literal-magic? - "Is this literal magic?" - [lit] - (let [pred (literal-predicate lit)] - (when (map? pred) - (:magic pred)))) - -(defn build-seed-bindings - "Given a seed literal, already adorned and in magic form, convert - its bound constants to new variables." - [s] - (assert (-> s :literal-type (isa? ::literal))) - (let [ntbs (map-values (fn [_] (gensym '?_gen_)) (:term-bindings s))] - (assoc s :term-bindings ntbs))) - - -;;; Semi-naive support - -(defn negated-literal - "Given a literal l, return a negated version" - [l] - (assert (-> l :literal-type (= ::literal))) - (assoc l :literal-type ::negated)) - -(defn delta-literal - "Given a literal l, return a delta version" - [l] - (let [pred* (:predicate l) - pred (if (map? pred*) pred* {:pred pred*})] - (assoc l :predicate (assoc pred :delta true)))) - - -;;; Database operations - -(defn- build-partial-tuple - [lit binds] - (let [tbs (:term-bindings lit) - each (fn [[key val :as pair]] - (if (is-var? val) - (if-let [n (binds val)] - [key n] - nil) - pair))] - (into {} (remove nil? (map each tbs))))) - -(defn- project-onto-literal - "Given a literal, and a materialized tuple, return a set of variable - bindings." - [lit tuple] - (let [step (fn [binds [key val]] - (if (and (is-var? val) - (contains? tuple key)) - (assoc binds val (tuple key)) - binds))] - (reduce step {} (:term-bindings lit)))) - - -(defn- join-literal* - [db lit bs fun] - (let [each (fn [binds] - (let [pt (build-partial-tuple lit binds)] - (fun binds pt)))] - (when (contains? db (literal-predicate lit)) - (apply concat (map each bs))))) - -(defmulti join-literal - "Given a database (db), a literal (lit) and a seq of bindings (bs), - return a new seq of bindings by joining this literal." - (fn [db lit bs] (:literal-type lit))) - -(defmethod join-literal ::literal - [db lit bs] - (join-literal* db lit bs (fn [binds pt] - (map #(merge binds %) - (map (partial project-onto-literal lit) - (select db (literal-predicate lit) pt)))))) - -(defmethod join-literal ::negated - [db lit bs] - (join-literal* db lit bs (fn [binds pt] - (if (any-match? db (literal-predicate lit) pt) - nil - [binds])))) - -(defmethod join-literal ::conditional - [db lit bs] - (let [each (fn [binds] - (let [resolve (fn [term] - (if (is-var? term) - (binds term) - term)) - args (map resolve (:terms lit))] - (if ((:fun lit) args) - binds - nil)))] - (remove nil? (map each bs)))) - -(defn project-literal - "Project a stream of bindings onto a literal/relation. Returns a new - db." - ([db lit bs] (project-literal db lit bs is-var?)) - ([db lit bs var?] - (assert (= (:literal-type lit) ::literal)) - (let [rel-name (literal-predicate lit) - columns (-> lit :term-bindings keys) - idxs (vec (get-adorned-bindings (literal-predicate lit))) - db1 (ensure-relation db rel-name columns idxs) - rel (get-relation db1 rel-name) - step (fn [rel bindings] - (let [step (fn [t [k v]] - (if (var? v) - (assoc t k (bindings v)) - (assoc t k v))) - tuple (reduce step {} (:term-bindings lit))] - (add-tuple rel tuple)))] - (replace-relation db rel-name (reduce step rel bs))))) - - -;; End of file diff --git a/src/clojure/contrib/datalog/magic.clj b/src/clojure/contrib/datalog/magic.clj deleted file mode 100644 index ff6891a4..00000000 --- a/src/clojure/contrib/datalog/magic.clj +++ /dev/null @@ -1,128 +0,0 @@ -;; Copyright (c) Jeffrey Straszheim. 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. -;; -;; magic.clj -;; -;; A Clojure implementation of Datalog -- Magic Sets -;; -;; straszheimjeffrey (gmail) -;; Created 18 Feburary 2009 - - -(ns clojure.contrib.datalog.magic - (:use clojure.contrib.datalog.util - clojure.contrib.datalog.literals - clojure.contrib.datalog.rules) - (:use [clojure.set :only (union intersection difference)])) - - -;;; Adornment - -(defn adorn-query - "Adorn a query" - [q] - (adorned-literal q (get-self-bound-cs q))) - -(defn adorn-rules-set - "Adorns the given rules-set for the given query. (rs) is a - rules-set, (q) is an adorned query." - [rs q] - (let [i-preds (all-predicates rs) - p-map (predicate-map rs)] - (loop [nrs empty-rules-set ; The rules set being built - needed #{(literal-predicate q)}] - (if (empty? needed) - nrs - (let [pred (first needed) - remaining (disj needed pred) - base-pred (get-base-predicate pred) - bindings (get-adorned-bindings pred) - new-rules (p-map base-pred) - new-adorned-rules (map (partial compute-sip bindings i-preds) - new-rules) - new-nrs (reduce conj nrs new-adorned-rules) - current-preds (all-predicates new-nrs) - not-needed? (fn [pred] - (or (current-preds pred) - (-> pred get-base-predicate i-preds not))) - add-pred (fn [np pred] - (if (not-needed? pred) np (conj np pred))) - add-preds (fn [np rule] - (reduce add-pred np (map literal-predicate (:body rule)))) - new-needed (reduce add-preds remaining new-adorned-rules)] - (recur new-nrs new-needed)))))) - - -;;; Magic ! - -(defn seed-relation - "Given a magic form of a query, give back the literal form of its seed - relation" - [q] - (let [pred (-> q literal-predicate get-base-predicate) - bnds (-> q literal-predicate get-adorned-bindings)] - (with-meta (assoc q :predicate [pred :magic-seed bnds]) {}))) - -(defn seed-rule - "Given an adorned query, give back its seed rule" - [q] - (let [mq (build-seed-bindings (magic-literal q)) - sr (seed-relation mq)] - (build-rule mq [sr]))) - -(defn build-partial-tuple - "Given a query and a set of bindings, build a partial tuple needed - to extract the relation from the database." - [q bindings] - (into {} (remove nil? (map (fn [[k v :as pair]] - (if (is-var? v) - nil - (if (is-query-var? v) - [k (bindings v)] - pair))) - (:term-bindings q))))) - -(defn seed-predicate-for-insertion - "Given a query, return the predicate to use for database insertion." - [q] - (let [seed (-> q seed-rule :body first) - columns (-> seed :term-bindings keys) - new-term-bindings (-> q :term-bindings (select-keys columns))] - (assoc seed :term-bindings new-term-bindings))) - -(defn magic-transform - "Return a magic transformation of an adorned rules-set (rs). The - (i-preds) are the predicates of the intension database. These - default to the predicates within the rules-set." - ([rs] - (magic-transform rs (all-predicates rs))) - ([rs i-preds] - (let [not-duplicate? (fn [l mh bd] - (or (not (empty? bd)) - (not (= (magic-literal l) - mh)))) - xr (fn [rs rule] - (let [head (:head rule) - body (:body rule) - mh (magic-literal head) - answer-rule (build-rule head - (concat [mh] body)) - step (fn [[rs bd] l] - (if (and (i-preds (literal-predicate l)) - (not-duplicate? l mh bd)) - (let [nr (build-rule (magic-literal l) - (concat [mh] bd))] - [(conj rs nr) (conj bd l)]) - [rs (conj bd l)])) - [nrs _] (reduce step [rs []] body)] - (conj nrs answer-rule)))] - (reduce xr empty-rules-set rs)))) - - - -;; End of file diff --git a/src/clojure/contrib/datalog/rules.clj b/src/clojure/contrib/datalog/rules.clj deleted file mode 100644 index bcfe5c4c..00000000 --- a/src/clojure/contrib/datalog/rules.clj +++ /dev/null @@ -1,207 +0,0 @@ -;; Copyright (c) Jeffrey Straszheim. 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. -;; -;; rules.clj -;; -;; A Clojure implementation of Datalog -- Rules Engine -;; -;; straszheimjeffrey (gmail) -;; Created 2 Feburary 2009 - - -(ns clojure.contrib.datalog.rules - (use clojure.contrib.datalog.util) - (use clojure.contrib.datalog.literals - clojure.contrib.datalog.database) - (use [clojure.set :only (union intersection difference)]) - (use [clojure.contrib.set :only (subset?)]) - (use [clojure.contrib.except :only (throwf)])) - - -(defstruct datalog-rule - :head - :body) - -(defn display-rule - "Return the rule in a readable format." - [rule] - (list* '<- - (-> rule :head display-literal) - (map display-literal (:body rule)))) - -(defn display-query - "Return a query in a readable format." - [query] - (list* '?- (display-literal query))) - - -;;; Check rule safety - -(defn is-safe? - "Is the rule safe according to the datalog protocol?" - [rule] - (let [hv (literal-vars (:head rule)) - bpv (apply union (map positive-vars (:body rule))) - bnv (apply union (map negative-vars (:body rule))) - ehv (difference hv bpv) - env (difference bnv bpv)] - (when-not (empty? ehv) - (throwf "Head vars %s not bound in body in rule %s" ehv rule)) - (when-not (empty? env) - (throwf "Body vars %s not bound in negative positions in rule %s" env rule)) - rule)) - - -;;; Rule creation and printing - -(defn build-rule - [hd bd] - (with-meta (struct datalog-rule hd bd) {:type ::datalog-rule})) - -(defmacro <- - "Build a datalog rule. Like this: - - (<- (:head :x ?x :y ?y) (:body-1 :x ?x :y ?y) (:body-2 :z ?z) (not! :body-3 :x ?x) (if > ?y ?z))" - [hd & body] - (let [head (build-atom hd :clojure.contrib.datalog.literals/literal) - body (map build-literal body)] - `(is-safe? (build-rule ~head [~@body])))) - -(defmethod print-method ::datalog-rule - [rule #^Writer writer] - (print-method (display-rule rule) writer)) - -(defn return-rule-data - "Returns an untypted rule that will be fully printed" - [rule] - (with-meta rule {})) - -(defmacro ?- - "Define a datalog query" - [& q] - (let [qq (build-atom q :clojure.contrib.datalog.literals/literal)] - `(with-meta ~qq {:type ::datalog-query}))) - -(defmethod print-method ::datalog-query - [query #^Writer writer] - (print-method (display-query query) writer)) - - - -;;; SIP - -(defn compute-sip - "Given a set of bound column names, return an adorned sip for this - rule. A set of intensional predicates should be provided to - determine what should be adorned." - [bindings i-preds rule] - (let [next-lit (fn [bv body] - (or (first (drop-while - #(not (literal-appropriate? bv %)) - body)) - (first (drop-while (complement positive?) body)))) - adorn (fn [lit bvs] - (if (i-preds (literal-predicate lit)) - (let [bnds (union (get-cs-from-vs lit bvs) - (get-self-bound-cs lit))] - (adorned-literal lit bnds)) - lit)) - new-h (adorned-literal (:head rule) bindings)] - (loop [bound-vars (get-vs-from-cs (:head rule) bindings) - body (:body rule) - sip []] - (if-let [next (next-lit bound-vars body)] - (recur (union bound-vars (literal-vars next)) - (remove #(= % next) body) - (conj sip (adorn next bound-vars))) - (build-rule new-h (concat sip body)))))) - - -;;; Rule sets - -(defn make-rules-set - "Given an existing set of rules, make it a 'rules-set' for - printing." - [rs] - (with-meta rs {:type ::datalog-rules-set})) - -(def empty-rules-set (make-rules-set #{})) - -(defn rules-set - "Given a collection of rules return a rules set" - [& rules] - (reduce conj empty-rules-set rules)) - -(defmethod print-method ::datalog-rules-set - [rules #^Writer writer] - (binding [*out* writer] - (do - (print "(rules-set") - (doseq [rule rules] - (println) - (print " ") - (print rule)) - (println ")")))) - -(defn predicate-map - "Given a rules-set, return a map of rules keyed by their predicates. - Each value will be a set of rules." - [rs] - (let [add-rule (fn [m r] - (let [pred (-> r :head literal-predicate) - os (get m pred #{})] - (assoc m pred (conj os r))))] - (reduce add-rule {} rs))) - -(defn all-predicates - "Given a rules-set, return all defined predicates" - [rs] - (set (map literal-predicate (map :head rs)))) - -(defn non-base-rules - "Return a collection of rules that depend, somehow, on other rules" - [rs] - (let [pred (all-predicates rs) - non-base (fn [r] - (if (some #(pred %) - (map literal-predicate (:body r))) - r - nil))] - (remove nil? (map non-base rs)))) - - -;;; Database operations - -(def empty-bindings [{}]) - -(defn apply-rule - "Apply the rule against db-1, adding the results to the appropriate - relation in db-2. The relation will be created if needed." - ([db rule] (apply-rule db db rule)) - ([db-1 db-2 rule] - (trace-datalog (println) - (println) - (println "--------------- Begin Rule ---------------") - (println rule)) - (let [head (:head rule) - body (:body rule) - step (fn [bs lit] - (trace-datalog (println bs) - (println lit)) - (join-literal db-1 lit bs)) - bs (reduce step empty-bindings body)] - (do (trace-datalog (println bs)) - (project-literal db-2 head bs))))) - -(defn apply-rules-set - [db rs] - (reduce (fn [rdb rule] - (apply-rule db rdb rule)) db rs)) - - -;; End of file
\ No newline at end of file diff --git a/src/clojure/contrib/datalog/softstrat.clj b/src/clojure/contrib/datalog/softstrat.clj deleted file mode 100644 index b65434c4..00000000 --- a/src/clojure/contrib/datalog/softstrat.clj +++ /dev/null @@ -1,161 +0,0 @@ -;; Copyright (c) Jeffrey Straszheim. 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. -;; -;; softstrat.clj -;; -;; A Clojure implementation of Datalog -- Soft Stratification -;; -;; straszheimjeffrey (gmail) -;; Created 28 Feburary 2009 - - -(ns clojure.contrib.datalog.softstrat - (:use clojure.contrib.datalog.util - clojure.contrib.datalog.database - clojure.contrib.datalog.literals - clojure.contrib.datalog.rules - clojure.contrib.datalog.magic) - (:use [clojure.set :only (union intersection difference)]) - (:use [clojure.contrib.seq-utils :only (indexed)]) - (:require [clojure.contrib.graph :as graph])) - - -;;; Dependency graph - -(defn- build-rules-graph - "Given a rules-set (rs), build a graph where each predicate symbol in rs, - there is a node n, and for each rule (<- h b-1 b-2 ...), there are edges - from the (literal-predicate h) -> (literal-predicate b-*), one for each - b-*." - [rs] - (let [preds (all-predicates rs) - pred-map (predicate-map rs) - step (fn [nbs pred] - (let [rules (pred-map pred) - preds (reduce (fn [pds lits] - (reduce (fn [pds lit] - (if-let [pred (literal-predicate lit)] - (conj pds pred) - pds)) - pds - lits)) - #{} - (map :body rules))] - (assoc nbs pred preds))) - neighbors (reduce step {} preds)] - (struct graph/directed-graph preds neighbors))) - -(defn- build-def - "Given a rules-set, build its def function" - [rs] - (let [pred-map (predicate-map rs) - graph (-> rs - build-rules-graph - graph/transitive-closure - graph/add-loops)] - (fn [pred] - (apply union (map set (map pred-map (graph/get-neighbors graph pred))))))) - - -;;; Soft Stratificattion REQ Graph - -(defn- req - "Returns a rules-set that is a superset of req(lit) for the lit at - index lit-index" - [rs soft-def rule lit-index] - (let [head (:head rule) - body (:body rule) - lit (nth body lit-index) - pre (subvec (vec body) 0 lit-index)] - (conj (-> lit literal-predicate soft-def (magic-transform (all-predicates rs))) - (build-rule (magic-literal lit) pre)))) - -(defn- rule-dep - "Given a rule, return the set of rules it depends on." - [rs mrs soft-def rule] - (let [step (fn [nrs [idx lit]] - (if (negated? lit) - (union nrs (req rs soft-def rule idx)) - nrs))] - (intersection mrs - (reduce step empty-rules-set (-> rule :body indexed))))) - -(defn- soft-strat-graph - "The dependency graph for soft stratification." - [rs mrs] - (let [soft-def (build-def rs) - step (fn [nbrs rule] - (assoc nbrs rule (rule-dep rs mrs soft-def rule))) - nbrs (reduce step {} mrs)] - (struct graph/directed-graph mrs nbrs))) - -(defn- build-soft-strat - "Given a rules-set (unadorned) and an adorned query, return the soft - stratified list. The rules will be magic transformed, and the - magic seed will be appended." - [rs q] - (let [ars (adorn-rules-set rs q) - mrs (conj (magic-transform ars) - (seed-rule q)) - gr (soft-strat-graph ars mrs)] - (map make-rules-set (graph/dependency-list gr)))) - - -;;; Work plan - -(defstruct soft-strat-work-plan - :query - :stratification) - -(defn build-soft-strat-work-plan - "Return a work plan for the given rules-set and query" - [rs q] - (let [aq (adorn-query q)] - (struct soft-strat-work-plan aq (build-soft-strat rs aq)))) - -(defn get-all-relations - "Return a set of all relation names defined in this workplan" - [ws] - (apply union (map all-predicates (:stratification ws)))) - - -;;; Evaluate - -(defn- weak-consq-operator - [db strat] - (trace-datalog (println) - (println) - (println "=============== Begin iteration ===============")) - (let [counts (database-counts db)] - (loop [strat strat] - (let [rs (first strat)] - (if rs - (let [new-db (apply-rules-set db rs)] - (if (= counts (database-counts new-db)) - (recur (next strat)) - new-db)) - db))))) - -(defn evaluate-soft-work-set - ([ws db] (evaluate-soft-work-set ws db {})) - ([ws db bindings] - (let [query (:query ws) - strat (:stratification ws) - seed (seed-predicate-for-insertion query) - seeded-db (project-literal db seed [bindings] is-query-var?) - fun (fn [data] - (weak-consq-operator data strat)) - equal (fn [db1 db2] - (= (database-counts db1) (database-counts db2))) - new-db (graph/fixed-point seeded-db fun nil equal) - pt (build-partial-tuple query bindings)] - (select new-db (literal-predicate query) pt)))) - - - -;; End of file diff --git a/src/clojure/contrib/datalog/tests/test.clj b/src/clojure/contrib/datalog/tests/test.clj deleted file mode 100644 index 121d264e..00000000 --- a/src/clojure/contrib/datalog/tests/test.clj +++ /dev/null @@ -1,45 +0,0 @@ -;; Copyright (c) Jeffrey Straszheim. 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. -;; -;; test.clj -;; -;; A Clojure implementation of Datalog -- Tests -;; -;; straszheimjeffrey (gmail) -;; Created 11 Feburary 2009 - -(ns clojure.contrib.datalog.tests.test - (:use [clojure.test :only (run-tests)]) - (:gen-class)) - -(def test-names [:test-util - :test-database - :test-literals - :test-rules - :test-magic - :test-softstrat]) - -(def test-namespaces - (map #(symbol (str "clojure.contrib.datalog.tests." (name %))) - test-names)) - -(defn run - "Runs all defined tests" - [] - (println "Loading tests...") - (apply require :reload-all test-namespaces) - (apply run-tests test-namespaces)) - -(defn -main - "Run all defined tests from the command line" - [& args] - (run) - (System/exit 0)) - - -;; End of file diff --git a/src/clojure/contrib/datalog/tests/test_database.clj b/src/clojure/contrib/datalog/tests/test_database.clj deleted file mode 100644 index 77719008..00000000 --- a/src/clojure/contrib/datalog/tests/test_database.clj +++ /dev/null @@ -1,153 +0,0 @@ -;; Copyright (c) Jeffrey Straszheim. 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. -;; -;; test-database.clj -;; -;; A Clojure implementation of Datalog -- Database -;; -;; straszheimjeffrey (gmail) -;; Created 12 Feburary 2009 - - -(ns clojure.contrib.datalog.tests.test-database - (:use clojure.test - clojure.contrib.datalog.database)) - - -(def test-db - (make-database - (relation :fred [:mary :sue]) - (index :fred :mary) - (relation :sally [:jen :becky :joan]) - (index :sally :jen) - (index :sally :becky))) - -(deftest test-make-database - (is (= test-db - (datalog-database - {:sally (datalog-relation - #{:jen :joan :becky} - #{} - {:becky {} - :jen {}}) - :fred (datalog-relation - #{:sue :mary} - #{} - {:mary {}})})))) - - -(deftest test-ensure-relation - (is (contains? (ensure-relation test-db :bob [:sam :george] [:sam]) :bob)) - (is (contains? (ensure-relation test-db :fred [:mary :sue] [:mary]) :fred)) - (is (thrown? AssertionError (ensure-relation test-db :fred [:bob :joe] [])))) - -(deftest test-add-tuple - (let [new-db (add-tuple test-db :fred {:mary 1 :sue 2})] - (is (= (select new-db :fred {:mary 1}) [{:mary 1 :sue 2}]))) - (is (thrown? AssertionError (add-tuple test-db :fred {:mary 1})))) - -(def test-db-1 - (add-tuples test-db - [:fred :mary 1 :sue 2] - [:fred :mary 2 :sue 3] - [:sally :jen 1 :becky 2 :joan 0] - [:sally :jen 1 :becky 4 :joan 3] - [:sally :jen 1 :becky 3 :joan 0] - [:sally :jen 1 :becky 2 :joan 3] - [:fred :mary 1 :sue 1] - [:fred :mary 3 :sue 1])) - -(deftest test-add-tuples - (is (= test-db-1 - (datalog-database - {:sally (datalog-relation - #{:jen :joan :becky} - #{{:jen 1, :joan 0, :becky 3} - {:jen 1, :joan 0, :becky 2} - {:jen 1, :joan 3, :becky 2} - {:jen 1, :joan 3, :becky 4}} - {:becky {3 - #{{:jen 1, :joan 0, :becky 3}} - 4 - #{{:jen 1, :joan 3, :becky 4}} - 2 - #{{:jen 1, :joan 0, :becky 2} - {:jen 1, :joan 3, :becky 2}}} - :jen {1 - #{{:jen 1, :joan 0, :becky 3} - {:jen 1, :joan 0, :becky 2} - {:jen 1, :joan 3, :becky 2} - {:jen 1, :joan 3, :becky 4}}}}) - :fred (datalog-relation - #{:sue :mary} - #{{:sue 2, :mary 1} - {:sue 1, :mary 1} - {:sue 3, :mary 2} - {:sue 1, :mary 3}} - {:mary {3 - #{{:sue 1, :mary 3}} - 2 - #{{:sue 3, :mary 2}} - 1 - #{{:sue 2, :mary 1} - {:sue 1, :mary 1}}}})})))) - -(deftest test-remove-tuples - (let [db (reduce #(apply remove-tuple %1 (first %2) (next %2)) - test-db-1 - [[:fred {:mary 1 :sue 1}] - [:fred {:mary 3 :sue 1}] - [:sally {:jen 1 :becky 2 :joan 0}] - [:sally {:jen 1 :becky 4 :joan 3}]])] - (is (= db - (datalog-database - {:sally (datalog-relation - #{:jen :joan :becky} - #{{:jen 1, :joan 0, :becky 3} - {:jen 1, :joan 3, :becky 2}} - {:becky - {3 - #{{:jen 1, :joan 0, :becky 3}} - 2 - #{{:jen 1, :joan 3, :becky 2}}} - :jen - {1 - #{{:jen 1, :joan 0, :becky 3} - {:jen 1, :joan 3, :becky 2}}}}) - :fred (datalog-relation - #{:sue :mary} - #{{:sue 2, :mary 1} - {:sue 3, :mary 2}} - {:mary - {2 - #{{:sue 3, :mary 2}} - 1 - #{{:sue 2, :mary 1}}}})}))))) - - - -(deftest test-select - (is (= (set (select test-db-1 :sally {:jen 1 :becky 2})) - #{{:jen 1 :joan 0 :becky 2} {:jen 1 :joan 3 :becky 2}})) - (is (= (set (select test-db-1 :fred {:sue 1}))) - #{{:mary 3 :sue 1} {:mary 1 :sue 1}}) - (is (empty? (select test-db-1 :sally {:joan 5 :jen 1})))) - -(deftest test-any-match? - (is (any-match? test-db-1 :fred {:mary 3})) - (is (any-match? test-db-1 :sally {:jen 1 :becky 2 :joan 3})) - (is (not (any-match? test-db-1 :sally {:jen 5}))) - (is (not (any-match? test-db-1 :fred {:mary 1 :sue 5})))) - - -(comment - (run-tests) -) - -;; End of file - diff --git a/src/clojure/contrib/datalog/tests/test_literals.clj b/src/clojure/contrib/datalog/tests/test_literals.clj deleted file mode 100644 index 36ee5147..00000000 --- a/src/clojure/contrib/datalog/tests/test_literals.clj +++ /dev/null @@ -1,187 +0,0 @@ -;; Copyright (c) Jeffrey Straszheim. 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. -;; -;; test-literals.clj -;; -;; A Clojure implementation of Datalog -- Literals tests -;; -;; straszheimjeffrey (gmail) -;; Created 25 Feburary 2009 - - -(ns clojure.contrib.datalog.tests.test-literals - (:use clojure.test) - (:use clojure.contrib.datalog.literals - clojure.contrib.datalog.database)) - - -(def pl (eval (build-literal '(:fred :x ?x :y ?y :z 3)))) -(def nl (eval (build-literal '(not! :fred :x ?x :y ?y :z 3)))) -(def cl (eval (build-literal '(if > ?x 3)))) - -(def bl (eval (build-literal '(:fred)))) - -(def bns {:x '?x :y '?y :z 3}) - -(deftest test-build-literal - (is (= (:predicate pl) :fred)) - (is (= (:term-bindings pl) bns)) - (is (= (:predicate nl) :fred)) - (is (= (:term-bindings nl) bns)) - (is (= (:symbol cl) '>)) - (is (= (:terms cl) '(?x 3))) - (is ((:fun cl) [4 3])) - (is (not ((:fun cl) [2 4]))) - (is (= (:predicate bl) :fred))) - -(deftest test-literal-predicate - (is (= (literal-predicate pl) :fred)) - (is (= (literal-predicate nl) :fred)) - (is (nil? (literal-predicate cl))) - (is (= (literal-predicate bl) :fred))) - -(deftest test-literal-columns - (is (= (literal-columns pl) #{:x :y :z})) - (is (= (literal-columns nl) #{:x :y :z})) - (is (nil? (literal-columns cl))) - (is (empty? (literal-columns bl)))) - -(deftest test-literal-vars - (is (= (literal-vars pl) #{'?x '?y})) - (is (= (literal-vars nl) #{'?x '?y})) - (is (= (literal-vars cl) #{'?x})) - (is (empty? (literal-vars bl)))) - -(deftest test-positive-vars - (is (= (positive-vars pl) (literal-vars pl))) - (is (nil? (positive-vars nl))) - (is (nil? (positive-vars cl))) - (is (empty? (positive-vars bl)))) - -(deftest test-negative-vars - (is (nil? (negative-vars pl))) - (is (= (negative-vars nl) (literal-vars nl))) - (is (= (negative-vars cl) (literal-vars cl))) - (is (empty? (negative-vars bl)))) - -(deftest test-negated? - (is (not (negated? pl))) - (is (negated? nl)) - (is (not (negated? cl)))) - -(deftest test-vs-from-cs - (is (= (get-vs-from-cs pl #{:x}) #{'?x})) - (is (empty? (get-vs-from-cs pl #{:z}))) - (is (= (get-vs-from-cs pl #{:x :r}) #{'?x})) - (is (empty? (get-vs-from-cs pl #{})))) - -(deftest test-cs-from-vs - (is (= (get-cs-from-vs pl #{'?x}) #{:x})) - (is (= (get-cs-from-vs pl #{'?x '?r}) #{:x})) - (is (empty? (get-cs-from-vs pl #{})))) - -(deftest test-literal-appropriate? - (is (not (literal-appropriate? #{} pl))) - (is (literal-appropriate? #{'?x} pl)) - (is (not (literal-appropriate? #{'?x} nl))) - (is (literal-appropriate? #{'?x '?y} nl)) - (is (not (literal-appropriate? #{'?z} cl))) - (is (literal-appropriate? #{'?x} cl))) - -(deftest test-adorned-literal - (is (= (literal-predicate (adorned-literal pl #{:x})) - {:pred :fred :bound #{:x}})) - (is (= (literal-predicate (adorned-literal nl #{:x :y :q})) - {:pred :fred :bound #{:x :y}})) - (is (= (:term-bindings (adorned-literal nl #{:x})) - {:x '?x :y '?y :z 3})) - (is (= (adorned-literal cl #{}) - cl))) - -(deftest test-get-adorned-bindings - (is (= (get-adorned-bindings (literal-predicate (adorned-literal pl #{:x}))) - #{:x})) - (is (= (get-adorned-bindings (literal-predicate pl)) - nil))) - -(deftest test-get-base-predicate - (is (= (get-base-predicate (literal-predicate (adorned-literal pl #{:x}))) - :fred)) - (is (= (get-base-predicate (literal-predicate pl)) - :fred))) - -(deftest test-magic-literal - (is (= (magic-literal pl) - {:predicate {:pred :fred :magic true}, :term-bindings {}, :literal-type :clojure.contrib.datalog.literals/literal})) - (is (= (magic-literal (adorned-literal pl #{:x})) - {:predicate {:pred :fred :magic true :bound #{:x}}, - :term-bindings {:x '?x}, - :literal-type :clojure.contrib.datalog.literals/literal}))) - -(comment - (use 'clojure.contrib.stacktrace) (e) - (use :reload 'clojure.contrib.datalog.literals) -) - - -(def db1 (make-database - (relation :fred [:x :y]) - (index :fred :x) - (relation :sally [:x]))) - -(def db2 (add-tuples db1 - [:fred :x 1 :y :mary] - [:fred :x 1 :y :becky] - [:fred :x 3 :y :sally] - [:fred :x 4 :y :joe] - [:sally :x 1] - [:sally :x 2])) - -(def lit1 (eval (build-literal '(:fred :x ?x :y ?y)))) -(def lit2 (eval (build-literal '(not! :fred :x ?x)))) -(def lit3 (eval (build-literal '(if > ?x ?y)))) -(def lit4 (adorned-literal (eval (build-literal '(:joan :x ?x :y ?y))) #{:x})) - -(deftest test-join-literal - (is (= (set (join-literal db2 lit1 [{'?x 1} {'?x 2} {'?x 3}])) - #{{'?x 1, '?y :mary} {'?x 1, '?y :becky} {'?x 3, '?y :sally}})) - (is (= (join-literal db2 lit2 [{'?x 1} {'?x 2} {'?x 3}]) - [{'?x 2}])) - (is (= (join-literal db2 lit3 [{'?x 1 '?y 2} {'?x 3 '?y 1}]) - [{'?x 3 '?y 1}]))) - -(deftest test-project-literal - (is (= ((project-literal db2 lit4 [{'?x 1 '?y 3}{'?x 4 '?y 2}]) {:pred :joan :bound #{:x}}) - (datalog-relation - ;; Schema - #{:y :x} - - ;; Data - #{ - {:x 1, :y 3} - {:x 4, :y 2} - } - - ;; Indexes - { - :x - { - 4 - #{{:x 4, :y 2}} - 1 - #{{:x 1, :y 3}} - } - })))) - - - -(comment - (run-tests) -) - -;; End of file diff --git a/src/clojure/contrib/datalog/tests/test_magic.clj b/src/clojure/contrib/datalog/tests/test_magic.clj deleted file mode 100644 index 7eabae78..00000000 --- a/src/clojure/contrib/datalog/tests/test_magic.clj +++ /dev/null @@ -1,72 +0,0 @@ -;; Copyright (c) Jeffrey Straszheim. 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. -;; -;; test-magic.clj -;; -;; A Clojure implementation of Datalog -- Magic Tests -;; -;; straszheimjeffrey (gmail) -;; Created 18 Feburary 2009 - -(ns clojure.contrib.datalog.tests.test-magic - (:use clojure.test) - (:use clojure.contrib.datalog.magic - clojure.contrib.datalog.rules)) - - - -(def rs (rules-set - (<- (:p :x ?x :y ?y) (:e :x ?x :y ?y)) - (<- (:p :x ?x :y ?y) (:e :x ?x :y ?z) (:p :x ?z :y ?y)) - (<- (:e :x ?x :y ?y) (:b :x ?x :y ?y)) - (<- (:e :x ?y :y ?y) (:c :x ?x :y ?y)))) - -(def q (adorn-query (?- :p :x 1 :y ?y))) - -(def ars (adorn-rules-set rs q)) - -(deftest test-adorn-rules-set - (is (= ars - (rules-set - (<- ({:pred :p :bound #{:x}} :y ?y :x ?x) ({:pred :e :bound #{:x}} :y ?y :x ?x)) - (<- ({:pred :p :bound #{:x}} :y ?y :x ?x) ({:pred :e :bound #{:x}} :y ?z :x ?x) - ({:pred :p :bound #{:x}} :y ?y :x ?z)) - (<- ({:pred :e :bound #{:x}} :y ?y :x ?y) (:c :y ?y :x ?x)) - (<- ({:pred :e :bound #{:x}} :y ?y :x ?x) (:b :y ?y :x ?x)))))) - - -(def m (magic-transform ars)) - -(deftest test-magic-transform - (is (= m - (rules-set - (<- ({:pred :e :bound #{:x}} :y ?y :x ?y) ({:pred :e :magic true :bound #{:x}} :x ?y) (:c :y ?y :x ?x)) - - (<- ({:pred :e :bound #{:x}} :y ?y :x ?x) ({:pred :e :magic true :bound #{:x}} :x ?x) (:b :y ?y :x ?x)) - - (<- ({:pred :p :magic true :bound #{:x}} :x ?z) ({:pred :p :magic true :bound #{:x}} :x ?x) - ({:pred :e :bound #{:x}} :y ?z :x ?x)) - - (<- ({:pred :p :bound #{:x}} :y ?y :x ?x) ({:pred :p :magic true :bound #{:x}} :x ?x) - ({:pred :e :bound #{:x}} :y ?z :x ?x) - ({:pred :p :bound #{:x}} :y ?y :x ?z)) - - (<- ({:pred :e :magic true :bound #{:x}} :x ?x) ({:pred :p :magic true :bound #{:x}} :x ?x)) - - (<- ({:pred :p :bound #{:x}} :y ?y :x ?x) ({:pred :p :magic true :bound #{:x}} :x ?x) - ({:pred :e :bound #{:x}} :y ?y :x ?x)))))) - - - - -(comment - (run-tests) -) - -;; End of file - diff --git a/src/clojure/contrib/datalog/tests/test_rules.clj b/src/clojure/contrib/datalog/tests/test_rules.clj deleted file mode 100644 index 8b80b770..00000000 --- a/src/clojure/contrib/datalog/tests/test_rules.clj +++ /dev/null @@ -1,130 +0,0 @@ -;; Copyright (c) Jeffrey Straszheim. 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. -;; -;; test-rules.clj -;; -;; A Clojure implementation of Datalog -- Rule Tests -;; -;; straszheimjeffrey (gmail) -;; Created 12 Feburary 2009 - - -(ns clojure.contrib.datalog.tests.test-rules - (:use clojure.test - clojure.contrib.datalog.rules - clojure.contrib.datalog.literals - clojure.contrib.datalog.database)) - - -(def tr-1 (<- (:fred :x ?x :y ?y) (:mary :x ?x :z ?z) (:sally :z ?z :y ?y))) -(def tr-2 (<- (:fred) (not! :mary :x 3))) -(def tr-3 (<- (:fred :x ?x :y ?y) (if > ?x ?y) (:mary :x ?x) (:sally :y ?y))) - - - -(deftest test-rule-safety - (is (thrown-with-msg? Exception #".*Head vars.*not bound.*" - (<- (:fred :x ?x) (:sally :y ?y)))) - (is (thrown-with-msg? Exception #".*Body vars.*not bound.*negative position.*" - (<- (:fred :x ?x) (:becky :x ?x) (not! :sally :y ?y)))) - (is (thrown-with-msg? Exception #".*Body vars.*not bound.*negative position.*" - (<- (:fred :x ?x) (:becky :x ?x) (if > ?x ?y))))) - - -(deftest test-sip - (is (= (compute-sip #{:x} #{:mary :sally} tr-1) - (<- ({:pred :fred :bound #{:x}} :x ?x :y ?y) - ({:pred :mary :bound #{:x}} :z ?z :x ?x) - ({:pred :sally :bound #{:z}} :y ?y :z ?z)))) - - (is (= (compute-sip #{} #{:mary :sally} tr-1) - (<- (:fred :y ?y :x ?x) (:mary :z ?z :x ?x) ({:pred :sally :bound #{:z}} :y ?y :z ?z)))) - - (is (= (compute-sip #{} #{:mary} tr-2) - (<- (:fred) (not! {:pred :mary :bound #{:x}} :x 3)))) - - (is (= (compute-sip #{} #{} tr-2) - tr-2)) - - (is (= (display-rule (compute-sip #{:x} #{:mary :sally} tr-3)) - (display-rule (<- ({:pred :fred :bound #{:x}} :x ?x :y ?y) - ({:pred :mary :bound #{:x}} :x ?x) - (:sally :y ?y) - (if > ?x ?y)))))) - ; Display rule is used because = does not work on - ; (if > ?x ?y) because it contains a closure - - -(def rs - (rules-set - (<- (:path :a ?x :b ?y) (:edge :a ?x :b ?y)) - (<- (:path :a ?x :b ?y) (:edge :a ?x :b ?z) (:path :a ?z :b ?y)) - (<- (:edge :a ?x :b ?y) (:route :a ?x :b ?y) (if not= ?x ?y)))) - -(deftest test-rules-set - (is (= (count rs) 3)) - (is (contains? rs (<- (:path :a ?x :b ?y) (:edge :a ?x :b ?z) (:path :a ?z :b ?y))))) - -(deftest test-predicate-map - (let [pm (predicate-map rs)] - (is (= (pm :path) - #{(<- (:path :a ?x :b ?y) (:edge :a ?x :b ?y)) - (<- (:path :a ?x :b ?y) (:edge :a ?x :b ?z) (:path :a ?z :b ?y))})) - (is (= (-> :edge pm count) 1)))) - - -(def db1 (make-database - (relation :fred [:x :y]) - (index :fred :x) - (relation :sally [:x]) - (relation :ben [:y]))) - -(def db2 (add-tuples db1 - [:fred :x 1 :y :mary] - [:fred :x 1 :y :becky] - [:fred :x 3 :y :sally] - [:fred :x 4 :y :joe] - [:fred :x 4 :y :bob] - [:sally :x 1] - [:sally :x 2] - [:sally :x 3] - [:sally :x 4] - [:ben :y :bob])) - - -(deftest test-apply-rule - (is (= (apply-rule db2 empty-database (<- (:becky :y ?y) (:sally :x ?x) - (:fred :x ?x :y ?y) - (not! :ben :y ?y) - (if not= ?x 3))) - (datalog-database - { - :becky - (datalog-relation - ;; Schema - #{:y} - ;; Data - #{ - {:y :joe} - {:y :mary} - {:y :becky} - } - ;; Indexes - { - }) - })))) - - - - -(comment - (run-tests) -) - -;; End of file - diff --git a/src/clojure/contrib/datalog/tests/test_softstrat.clj b/src/clojure/contrib/datalog/tests/test_softstrat.clj deleted file mode 100644 index a33d8c96..00000000 --- a/src/clojure/contrib/datalog/tests/test_softstrat.clj +++ /dev/null @@ -1,233 +0,0 @@ -;; Copyright (c) Jeffrey Straszheim. 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. -;; -;; test-softstrat.clj -;; -;; A Clojure implementation of Datalog -- Soft Stratification Tests -;; -;; straszheimjeffrey (gmail) -;; Created 28 Feburary 2009 - -(ns clojure.contrib.datalog.tests.test-softstrat - (:use clojure.test) - (:use clojure.contrib.datalog.softstrat - clojure.contrib.datalog.magic - clojure.contrib.datalog.rules - clojure.contrib.datalog.database) - (:use [clojure.contrib.set :only (subset?)])) - - - -(def rs1 (rules-set - (<- (:p :x ?x) (:b :x ?x :y ?y :z ?z) (not! :q :x ?x) (not! :q :x ?y) (not! :q :x ?z)) - (<- (:q :x ?x) (:d :x ?x)))) - -(def q1 (?- :p :x 1)) - -(def ws (build-soft-strat-work-plan rs1 q1)) - -(deftest test-soft-stratification - (let [soft (:stratification ws) - q (:query ws)] - (is (= q (?- {:pred :p :bound #{:x}} :x 1))) - (is (= (count soft) 4)) - (is (subset? (rules-set - (<- ({:pred :q :bound #{:x}} :x ?x) ({:pred :q :magic true :bound #{:x}} :x ?x) - (:d :x ?x)) - - (<- ({:pred :q :magic true :bound #{:x}} :x ?x) ({:pred :p :magic true :bound #{:x}} :x ?x) - (:b :z ?z :y ?y :x ?x))) - (nth soft 0))) - (is (= (nth soft 1) - (rules-set - (<- ({:pred :q :magic true :bound #{:x}} :x ?y) ({:pred :p :magic true :bound #{:x}} :x ?x) - (:b :z ?z :y ?y :x ?x) - (not! {:pred :q :bound #{:x}} :x ?x))))) - (is (= (nth soft 2) - (rules-set - (<- ({:pred :q :magic true :bound #{:x}} :x ?z) ({:pred :p :magic true :bound #{:x}} :x ?x) - (:b :z ?z :y ?y :x ?x) - (not! {:pred :q :bound #{:x}} :x ?x) - (not! {:pred :q :bound #{:x}} :x ?y))))) - (is (= (nth soft 3) - (rules-set - (<- ({:pred :p :bound #{:x}} :x ?x) ({:pred :p :magic true :bound #{:x}} :x ?x) - (:b :z ?z :y ?y :x ?x) - (not! {:pred :q :bound #{:x}} :x ?x) - (not! {:pred :q :bound #{:x}} :x ?y) - (not! {:pred :q :bound #{:x}} :x ?z))))))) - - -(def tdb-1 - (make-database - (relation :b [:x :y :z]) - (relation :d [:x]))) - -(def tdb-2 - (add-tuples tdb-1 - [:b :x 1 :y 2 :z 3])) - -(deftest test-tdb-2 - (is (= (evaluate-soft-work-set ws tdb-2 {}) - [{:x 1}]))) - - - -(def tdb-3 - (add-tuples tdb-2 - [:d :x 2] - [:d :x 3])) - -(deftest test-tdb-3 - (is (empty? (evaluate-soft-work-set ws tdb-3 {})))) - - - -;;;;;;;;;;; - - - -(def db-base - (make-database - (relation :employee [:id :name :position]) - (index :employee :name) - - (relation :boss [:employee-id :boss-id]) - (index :boss :employee-id) - - (relation :can-do-job [:position :job]) - (index :can-do-job :position) - - (relation :job-replacement [:job :can-be-done-by]) - - (relation :job-exceptions [:id :job]))) - -(def db - (add-tuples db-base - [:employee :id 1 :name "Bob" :position :boss] - [:employee :id 2 :name "Mary" :position :chief-accountant] - [:employee :id 3 :name "John" :position :accountant] - [:employee :id 4 :name "Sameer" :position :chief-programmer] - [:employee :id 5 :name "Lilian" :position :programmer] - [:employee :id 6 :name "Li" :position :technician] - [:employee :id 7 :name "Fred" :position :sales] - [:employee :id 8 :name "Brenda" :position :sales] - [:employee :id 9 :name "Miki" :position :project-management] - [:employee :id 10 :name "Albert" :position :technician] - - [:boss :employee-id 2 :boss-id 1] - [:boss :employee-id 3 :boss-id 2] - [:boss :employee-id 4 :boss-id 1] - [:boss :employee-id 5 :boss-id 4] - [:boss :employee-id 6 :boss-id 4] - [:boss :employee-id 7 :boss-id 1] - [:boss :employee-id 8 :boss-id 7] - [:boss :employee-id 9 :boss-id 1] - [:boss :employee-id 10 :boss-id 6] - - [:can-do-job :position :boss :job :management] - [:can-do-job :position :accountant :job :accounting] - [:can-do-job :position :chief-accountant :job :accounting] - [:can-do-job :position :programmer :job :programming] - [:can-do-job :position :chief-programmer :job :programming] - [:can-do-job :position :technician :job :server-support] - [:can-do-job :position :sales :job :sales] - [:can-do-job :position :project-management :job :project-management] - - [:job-replacement :job :pc-support :can-be-done-by :server-support] - [:job-replacement :job :pc-support :can-be-done-by :programming] - [:job-replacement :job :payroll :can-be-done-by :accounting] - - [:job-exceptions :id 4 :job :pc-support])) - -(def rules - (rules-set - (<- (:works-for :employee ?x :boss ?y) (:boss :employee-id ?e-id :boss-id ?b-id) - (:employee :id ?e-id :name ?x) - (:employee :id ?b-id :name ?y)) - (<- (:works-for :employee ?x :boss ?y) (:works-for :employee ?x :boss ?z) - (:works-for :employee ?z :boss ?y)) - (<- (:employee-job* :employee ?x :job ?y) (:employee :name ?x :position ?pos) - (:can-do-job :position ?pos :job ?y)) - (<- (:employee-job* :employee ?x :job ?y) (:job-replacement :job ?y :can-be-done-by ?z) - (:employee-job* :employee ?x :job ?z)) - (<- (:employee-job* :employee ?x :job ?y) (:can-do-job :job ?y) - (:employee :name ?x :position ?z) - (if = ?z :boss)) - (<- (:employee-job :employee ?x :job ?y) (:employee-job* :employee ?x :job ?y) - (:employee :id ?id :name ?x) - (not! :job-exceptions :id ?id :job ?y)) - (<- (:bj :name ?x :boss ?y) (:works-for :employee ?x :boss ?y) - (not! :employee-job :employee ?y :job :pc-support)))) - - -(def ws-1 (build-soft-strat-work-plan rules (?- :works-for :employee '??name :boss ?x))) -(defn evaluate-1 [name] (set (evaluate-soft-work-set ws-1 db {'??name name}))) - -(deftest test-ws-1 - (is (= (evaluate-1 "Albert") - #{{:employee "Albert", :boss "Li"} - {:employee "Albert", :boss "Sameer"} - {:employee "Albert", :boss "Bob"}})) - (is (empty? (evaluate-1 "Bob"))) - (is (= (evaluate-1 "John") - #{{:employee "John", :boss "Bob"} - {:employee "John", :boss "Mary"}}))) - - -(def ws-2 (build-soft-strat-work-plan rules (?- :employee-job :employee '??name :job ?x))) -(defn evaluate-2 [name] (set (evaluate-soft-work-set ws-2 db {'??name name}))) - -(deftest test-ws-2 - (is (= (evaluate-2 "Albert") - #{{:employee "Albert", :job :pc-support} - {:employee "Albert", :job :server-support}})) - (is (= (evaluate-2 "Sameer") - #{{:employee "Sameer", :job :programming}})) - (is (= (evaluate-2 "Bob") - #{{:employee "Bob", :job :accounting} - {:employee "Bob", :job :management} - {:employee "Bob", :job :payroll} - {:employee "Bob", :job :pc-support} - {:employee "Bob", :job :project-management} - {:employee "Bob", :job :programming} - {:employee "Bob", :job :server-support} - {:employee "Bob", :job :sales}}))) - -(def ws-3 (build-soft-strat-work-plan rules (?- :bj :name '??name :boss ?x))) -(defn evaluate-3 [name] (set (evaluate-soft-work-set ws-3 db {'??name name}))) - -(deftest test-ws-3 - (is (= (evaluate-3 "Albert") - #{{:name "Albert", :boss "Sameer"}}))) - -(def ws-4 (build-soft-strat-work-plan rules (?- :works-for :name ?x :boss ?x))) - -(deftest test-ws-4 - (is (= (set (evaluate-soft-work-set ws-4 db {})) - #{{:employee "Miki", :boss "Bob"} - {:employee "Albert", :boss "Li"} - {:employee "Lilian", :boss "Sameer"} - {:employee "Li", :boss "Bob"} - {:employee "Lilian", :boss "Bob"} - {:employee "Brenda", :boss "Fred"} - {:employee "Fred", :boss "Bob"} - {:employee "John", :boss "Bob"} - {:employee "John", :boss "Mary"} - {:employee "Albert", :boss "Sameer"} - {:employee "Sameer", :boss "Bob"} - {:employee "Albert", :boss "Bob"} - {:employee "Brenda", :boss "Bob"} - {:employee "Mary", :boss "Bob"} - {:employee "Li", :boss "Sameer"}}))) - -(comment - (run-tests) -) - -;; End of file diff --git a/src/clojure/contrib/datalog/tests/test_util.clj b/src/clojure/contrib/datalog/tests/test_util.clj deleted file mode 100644 index 9a5d0460..00000000 --- a/src/clojure/contrib/datalog/tests/test_util.clj +++ /dev/null @@ -1,69 +0,0 @@ -;; Copyright (c) Jeffrey Straszheim. 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. -;; -;; test-util.clj -;; -;; A Clojure implementation of Datalog -- Utilities Tests -;; -;; straszheimjeffrey (gmail) -;; Created 11 Feburary 2009 - -(ns clojure.contrib.datalog.tests.test-util - (:use clojure.test - clojure.contrib.datalog.util) - (:use [clojure.contrib.except :only (throwf)])) - -(deftest test-is-var? - (is (is-var? '?x)) - (is (is-var? '?)) - (is (not (is-var? '??x))) - (is (not (is-var? '??))) - (is (not (is-var? 'x))) - (is (not (is-var? "fred"))) - (is (not (is-var? :q)))) - -(deftest test-map-values - (let [map {:fred 1 :sally 2}] - (is (= (map-values #(* 2 %) map) {:fred 2 :sally 4})) - (is (= (map-values identity {}) {})))) - -(deftest test-keys-to-vals - (let [map {:fred 1 :sally 2 :joey 3}] - (is (= (set (keys-to-vals map [:fred :sally])) #{1 2})) - (is (= (set (keys-to-vals map [:fred :sally :becky])) #{1 2})) - (is (empty? (keys-to-vals map []))) - (is (empty? (keys-to-vals {} [:fred]))))) - -(deftest test-reverse-map - (let [map {:fred 1 :sally 2 :joey 3} - map-1 (assoc map :mary 3)] - (is (= (reverse-map map) {1 :fred 2 :sally 3 :joey})) - (is (or (= (reverse-map map-1) {1 :fred 2 :sally 3 :joey}) - (= (reverse-map map-1) {1 :fred 2 :sally 3 :mary}))))) - -(def some-maps - [ - { :a 1 :b 2 } - { :c 3 :b 3 } - { :d 4 :a 1 } - { :g 4 :b 4 } - { :a 2 :b 1 } - { :e 1 :f 1 } - ]) - -(def reduced (preduce + some-maps)) -(def merged (apply merge-with + some-maps)) - -(deftest test-preduce - (is (= reduced merged))) - -(comment - (run-tests) -) - -; End of file diff --git a/src/clojure/contrib/datalog/util.clj b/src/clojure/contrib/datalog/util.clj deleted file mode 100644 index b887f85c..00000000 --- a/src/clojure/contrib/datalog/util.clj +++ /dev/null @@ -1,89 +0,0 @@ -;; Copyright (c) Jeffrey Straszheim. 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. -;; -;; util.clj -;; -;; A Clojure implementation of Datalog -- Utilities -;; -;; straszheimjeffrey (gmail) -;; Created 3 Feburary 2009 - - -(ns clojure.contrib.datalog.util - (:use [clojure.contrib.seq-utils :only (separate)])) - - - -;;; Bindings and logic vars. A binding in a hash of logic vars to -;;; bound values. Logic vars are any symbol prefixed with a \?. - -(defn is-var? - "Is this a logic variable: e.g. a symbol prefixed with a ?" - [sym] - (when (symbol? sym) - (let [name (name sym)] - (and (= \? (first name)) - (not= \? (fnext name)))))) - -(defn is-query-var? - "Is this a query variable: e.g. a symbol prefixed with ??" - [sym] - (when (symbol? sym) - (let [name (name sym)] - (and (= \? (first name)) - (= \? (fnext name)))))) - -(defn map-values - "Like map, but works over the values of a hash map" - [f hash] - (let [key-vals (map (fn [[key val]] [key (f val)]) hash)] - (if (seq key-vals) - (apply conj (empty hash) key-vals) - hash))) - -(defn keys-to-vals - "Given a map and a collection of keys, return the collection of vals" - [m ks] - (vals (select-keys m ks))) - -(defn reverse-map - "Reverse the keys/values of a map" - [m] - (into {} (map (fn [[k v]] [v k]) m))) - - -;;; Preduce -- A parallel reduce over hashes - -(defn preduce - "Similar to merge-with, but the contents of each key are merged in - parallel using f. - - f - a function of 2 arguments. - data - a collection of hashes." - [f data] - (let [data-1 (map (fn [h] (map-values #(list %) h)) data) - merged (doall (apply merge-with concat data-1)) - ; Groups w/ multiple elements are identified for parallel processing - [complex simple] (separate (fn [[key vals]] (> (count vals) 1)) merged) - fold-group (fn [[key vals]] {key (reduce f vals)}) - fix-single (fn [[key [val]]] [key val])] - (apply merge (concat (pmap fold-group merged) (map fix-single simple))))) - - -;;; Debuging and Tracing - -(def *trace-datalog* nil) - -(defmacro trace-datalog - "If *test-datalog* is set to true, run the enclosed commands" - [& body] - `(when *trace-datalog* - ~@body)) - - -;; End of file diff --git a/src/clojure/contrib/def.clj b/src/clojure/contrib/def.clj deleted file mode 100644 index cc3eef75..00000000 --- a/src/clojure/contrib/def.clj +++ /dev/null @@ -1,147 +0,0 @@ -;; Copyright (c) Stephen C. Gilardi. 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. -;; -;; File: def.clj -;; -;; def.clj provides variants of def that make including doc strings and -;; making private definitions more succinct. -;; -;; scgilardi (gmail) -;; 17 May 2008 - -(ns - #^{:author "Stephen C. Gilardi", - :doc "def.clj provides variants of def that make including doc strings and -making private definitions more succinct."} - clojure.contrib.def) - -(defmacro defvar - "Defines a var with an optional intializer and doc string" - ([name] - (list `def name)) - ([name init] - (list `def name init)) - ([name init doc] - (list `def (with-meta name (assoc (meta name) :doc doc)) init))) - -(defmacro defunbound - "Defines an unbound var with optional doc string" - ([name] - (list `def name)) - ([name doc] - (list `def (with-meta name (assoc (meta name) :doc doc))))) - -(defmacro defmacro- - "Same as defmacro but yields a private definition" - [name & decls] - (list* `defmacro (with-meta name (assoc (meta name) :private true)) decls)) - -(defmacro defvar- - "Same as defvar but yields a private definition" - [name & decls] - (list* `defvar (with-meta name (assoc (meta name) :private true)) decls)) - -(defmacro defunbound- - "Same as defunbound but yields a private definition" - [name & decls] - (list* `defunbound (with-meta name (assoc (meta name) :private true)) decls)) - -(defmacro defstruct- - "Same as defstruct but yields a private definition" - [name & decls] - (list* `defstruct (with-meta name (assoc (meta name) :private true)) decls)) - -(defmacro defonce- - "Same as defonce but yields a private definition" - ([name expr] - (list `defonce (with-meta name (assoc (meta name) :private true)) expr)) - ([name expr doc] - (list `defonce (with-meta name (assoc (meta name) :private true :doc doc)) expr))) - -(defmacro defalias - "Defines an alias for a var: a new var with the same root binding (if - any) and similar metadata. The metadata of the alias is its initial - metadata (as provided by def) merged into the metadata of the original." - ([name orig] - `(do - (alter-meta! - (if (.hasRoot (var ~orig)) - (def ~name (.getRoot (var ~orig))) - (def ~name)) - conj - (apply dissoc (meta (var ~orig)) (keys (meta (var ~name))))) - (var ~name))) - ([name orig doc] - (list `defalias (with-meta name (assoc (meta name) :doc doc)) orig))) - -; defhinted by Chouser: -(defmacro defhinted - "Defines a var with a type hint matching the class of the given - init. Be careful about using any form of 'def' or 'binding' to a - value of a different type. See http://paste.lisp.org/display/73344" - [sym init] - `(do - (def ~sym ~init) - (alter-meta! (var ~sym) assoc :tag (class ~sym)) - (var ~sym))) - -; name-with-attributes by Konrad Hinsen: -(defn name-with-attributes - "To be used in macro definitions. - Handles optional docstrings and attribute maps for a name to be defined - in a list of macro arguments. If the first macro argument is a string, - it is added as a docstring to name and removed from the macro argument - list. If afterwards the first macro argument is a map, its entries are - added to the name's metadata map and the map is removed from the - macro argument list. The return value is a vector containing the name - with its extended metadata map and the list of unprocessed macro - arguments." - [name macro-args] - (let [[docstring macro-args] (if (string? (first macro-args)) - [(first macro-args) (next macro-args)] - [nil macro-args]) - [attr macro-args] (if (map? (first macro-args)) - [(first macro-args) (next macro-args)] - [{} macro-args]) - attr (if docstring - (assoc attr :doc docstring) - attr) - attr (if (meta name) - (conj (meta name) attr) - attr)] - [(with-meta name attr) macro-args])) - -; defnk by Meikel Brandmeyer: -(defmacro defnk - "Define a function accepting keyword arguments. Symbols up to the first - keyword in the parameter list are taken as positional arguments. Then - an alternating sequence of keywords and defaults values is expected. The - values of the keyword arguments are available in the function body by - virtue of the symbol corresponding to the keyword (cf. :keys destructuring). - defnk accepts an optional docstring as well as an optional metadata map." - [fn-name & fn-tail] - (let [[fn-name [args & body]] (name-with-attributes fn-name fn-tail) - [pos kw-vals] (split-with symbol? args) - syms (map #(-> % name symbol) (take-nth 2 kw-vals)) - values (take-nth 2 (rest kw-vals)) - sym-vals (apply hash-map (interleave syms values)) - de-map {:keys (vec syms) - :or sym-vals}] - `(defn ~fn-name - [~@pos & options#] - (let [~de-map (apply hash-map options#)] - ~@body)))) - -; defn-memo by Chouser: -(defmacro defn-memo - "Just like defn, but memoizes the function using clojure.core/memoize" - [fn-name & defn-stuff] - `(do - (defn ~fn-name ~@defn-stuff) - (alter-var-root (var ~fn-name) memoize) - (var ~fn-name))) diff --git a/src/clojure/contrib/duck_streams.clj b/src/clojure/contrib/duck_streams.clj deleted file mode 100644 index 027aae4d..00000000 --- a/src/clojure/contrib/duck_streams.clj +++ /dev/null @@ -1,416 +0,0 @@ -;;; duck_streams.clj -- duck-typed I/O streams for Clojure - -;; by Stuart Sierra, http://stuartsierra.com/ -;; May 13, 2009 - -;; Copyright (c) Stuart Sierra, 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 file defines "duck-typed" I/O utility functions for Clojure. -;; The 'reader' and 'writer' functions will open and return an -;; instance of java.io.BufferedReader and java.io.PrintWriter, -;; respectively, for a variety of argument types -- filenames as -;; strings, URLs, java.io.File's, etc. 'reader' even works on http -;; URLs. -;; -;; Note: this is not really "duck typing" as implemented in languages -;; like Ruby. A better name would have been "do-what-I-mean-streams" -;; or "just-give-me-a-stream", but ducks are funnier. - - -;; CHANGE LOG -;; -;; May 13, 2009: added functions to open writers for appending -;; -;; May 3, 2009: renamed file to file-str, for compatibility with -;; clojure.contrib.java-utils. reader/writer no longer use this -;; function. -;; -;; February 16, 2009: (lazy branch) fixed read-lines to work with lazy -;; Clojure. -;; -;; January 10, 2009: added *default-encoding*, so streams are always -;; opened as UTF-8. -;; -;; December 19, 2008: rewrote reader and writer as multimethods; added -;; slurp*, file, and read-lines -;; -;; April 8, 2008: first version - - - -(ns - #^{:author "Stuart Sierra", - :doc "This file defines \"duck-typed\" I/O utility functions for Clojure. - The 'reader' and 'writer' functions will open and return an - instance of java.io.BufferedReader and java.io.PrintWriter, - respectively, for a variety of argument types -- filenames as - strings, URLs, java.io.File's, etc. 'reader' even works on http - URLs. - - Note: this is not really \"duck typing\" as implemented in languages - like Ruby. A better name would have been \"do-what-I-mean-streams\" - or \"just-give-me-a-stream\", but ducks are funnier."} - clojure.contrib.duck-streams - (:import - (java.io Reader InputStream InputStreamReader PushbackReader - BufferedReader File PrintWriter OutputStream - OutputStreamWriter BufferedWriter Writer - FileInputStream FileOutputStream ByteArrayOutputStream - StringReader ByteArrayInputStream) - (java.net URI URL MalformedURLException Socket))) - - -(def - #^{:doc "Name of the default encoding to use when reading & writing. - Default is UTF-8." - :tag "java.lang.String"} - *default-encoding* "UTF-8") - -(def - #^{:doc "Size, in bytes or characters, of the buffer used when - copying streams."} - *buffer-size* 1024) - -(def - #^{:doc "Type object for a Java primitive byte array."} - *byte-array-type* (class (make-array Byte/TYPE 0))) - - -(defn #^File file-str - "Concatenates args as strings and returns a java.io.File. Replaces - all / and \\ with File/separatorChar. Replaces ~ at the start of - the path with the user.home system property." - [& args] - (let [#^String s (apply str args) - s (.replaceAll (re-matcher #"[/\\]" s) File/separator) - s (if (.startsWith s "~") - (str (System/getProperty "user.home") - File/separator (subs s 1)) - s)] - (File. s))) - - -(defmulti #^{:tag BufferedReader - :doc "Attempts to coerce its argument into an open - java.io.BufferedReader. Argument may be an instance of Reader, - BufferedReader, InputStream, File, URI, URL, Socket, or String. - - If argument is a String, it tries to resolve it first as a URI, then - as a local file name. URIs with a 'file' protocol are converted to - local file names. Uses *default-encoding* as the text encoding. - - Should be used inside with-open to ensure the Reader is properly - closed." - :arglists '([x])} - reader class) - -(defmethod reader Reader [x] - (BufferedReader. x)) - -(defmethod reader InputStream [#^InputStream x] - (BufferedReader. (InputStreamReader. x *default-encoding*))) - -(defmethod reader File [#^File x] - (reader (FileInputStream. x))) - -(defmethod reader URL [#^URL x] - (reader (if (= "file" (.getProtocol x)) - (FileInputStream. (.getPath x)) - (.openStream x)))) - -(defmethod reader URI [#^URI x] - (reader (.toURL x))) - -(defmethod reader String [#^String x] - (try (let [url (URL. x)] - (reader url)) - (catch MalformedURLException e - (reader (File. x))))) - -(defmethod reader Socket [#^Socket x] - (reader (.getInputStream x))) - -(defmethod reader :default [x] - (throw (Exception. (str "Cannot open " (pr-str x) " as a reader.")))) - - -(def - #^{:doc "If true, writer and spit will open files in append mode. - Defaults to false. Use append-writer or append-spit." - :tag "java.lang.Boolean"} - *append-to-writer* false) - - -(defmulti #^{:tag PrintWriter - :doc "Attempts to coerce its argument into an open java.io.PrintWriter - wrapped around a java.io.BufferedWriter. Argument may be an - instance of Writer, PrintWriter, BufferedWriter, OutputStream, File, - URI, URL, Socket, or String. - - If argument is a String, it tries to resolve it first as a URI, then - as a local file name. URIs with a 'file' protocol are converted to - local file names. - - Should be used inside with-open to ensure the Writer is properly - closed." - :arglists '([x])} - writer class) - -(defn- assert-not-appending [] - (when *append-to-writer* - (throw (Exception. "Cannot change an open stream to append mode.")))) - -(defmethod writer PrintWriter [x] - (assert-not-appending) - x) - -(defmethod writer BufferedWriter [#^BufferedWriter x] - (assert-not-appending) - (PrintWriter. x)) - -(defmethod writer Writer [x] - (assert-not-appending) - ;; Writer includes sub-classes such as FileWriter - (PrintWriter. (BufferedWriter. x))) - -(defmethod writer OutputStream [#^OutputStream x] - (assert-not-appending) - (PrintWriter. - (BufferedWriter. - (OutputStreamWriter. x *default-encoding*)))) - -(defmethod writer File [#^File x] - (let [stream (FileOutputStream. x *append-to-writer*)] - (binding [*append-to-writer* false] - (writer stream)))) - -(defmethod writer URL [#^URL x] - (if (= "file" (.getProtocol x)) - (writer (File. (.getPath x))) - (throw (Exception. (str "Cannot write to non-file URL <" x ">"))))) - -(defmethod writer URI [#^URI x] - (writer (.toURL x))) - -(defmethod writer String [#^String x] - (try (let [url (URL. x)] - (writer url)) - (catch MalformedURLException err - (writer (File. x))))) - -(defmethod writer Socket [#^Socket x] - (writer (.getOutputStream x))) - -(defmethod writer :default [x] - (throw (Exception. (str "Cannot open <" (pr-str x) "> as a writer.")))) - - -(defn append-writer - "Like writer but opens file for appending. Does not work on streams - that are already open." - [x] - (binding [*append-to-writer* true] - (writer x))) - - -(defn write-lines - "Writes lines (a seq) to f, separated by newlines. f is opened with - writer, and automatically closed at the end of the sequence." - [f lines] - (with-open [#^PrintWriter writer (writer f)] - (loop [lines lines] - (when-let [line (first lines)] - (.write writer (str line)) - (.println writer) - (recur (rest lines)))))) - -(defn read-lines - "Like clojure.core/line-seq but opens f with reader. Automatically - closes the reader AFTER YOU CONSUME THE ENTIRE SEQUENCE." - [f] - (let [read-line (fn this [#^BufferedReader rdr] - (lazy-seq - (if-let [line (.readLine rdr)] - (cons line (this rdr)) - (.close rdr))))] - (read-line (reader f)))) - -(defn #^String slurp* - "Like clojure.core/slurp but opens f with reader." - [f] - (with-open [#^BufferedReader r (reader f)] - (let [sb (StringBuilder.)] - (loop [c (.read r)] - (if (neg? c) - (str sb) - (do (.append sb (char c)) - (recur (.read r)))))))) - -(defn spit - "Opposite of slurp. Opens f with writer, writes content, then - closes f." - [f content] - (with-open [#^PrintWriter w (writer f)] - (.print w content))) - -(defn append-spit - "Like spit but appends to file." - [f content] - (with-open [#^PrintWriter w (append-writer f)] - (.print w content))) - -(defn pwd - "Returns current working directory as a String. (Like UNIX 'pwd'.) - Note: In Java, you cannot change the current working directory." - [] - (System/getProperty "user.dir")) - - - -(defmacro with-out-writer - "Opens a writer on f, binds it to *out*, and evalutes body. - Anything printed within body will be written to f." - [f & body] - `(with-open [stream# (writer ~f)] - (binding [*out* stream#] - ~@body))) - -(defmacro with-out-append-writer - "Like with-out-writer but appends to file." - [f & body] - `(with-open [stream# (append-writer ~f)] - (binding [*out* stream#] - ~@body))) - -(defmacro with-in-reader - "Opens a PushbackReader on f, binds it to *in*, and evaluates body." - [f & body] - `(with-open [stream# (PushbackReader. (reader ~f))] - (binding [*in* stream#] - ~@body))) - -(defmulti - #^{:doc "Copies input to output. Returns nil. - Input may be an InputStream, Reader, File, byte[], or String. - Output may be an OutputStream, Writer, or File. - - Does not close any streams except those it opens itself - (on a File). - - Writing a File fails if the parent directory does not exist." - :arglists '([input output])} - copy - (fn [input output] [(type input) (type output)])) - -(defmethod copy [InputStream OutputStream] [#^InputStream input #^OutputStream output] - (let [buffer (make-array Byte/TYPE *buffer-size*)] - (loop [] - (let [size (.read input buffer)] - (when (pos? size) - (do (.write output buffer 0 size) - (recur))))))) - -(defmethod copy [InputStream Writer] [#^InputStream input #^Writer output] - (let [#^"[B" buffer (make-array Byte/TYPE *buffer-size*)] - (loop [] - (let [size (.read input buffer)] - (when (pos? size) - (let [chars (.toCharArray (String. buffer 0 size *default-encoding*))] - (do (.write output chars) - (recur)))))))) - -(defmethod copy [InputStream File] [#^InputStream input #^File output] - (with-open [out (FileOutputStream. output)] - (copy input out))) - -(defmethod copy [Reader OutputStream] [#^Reader input #^OutputStream output] - (let [#^"[C" buffer (make-array Character/TYPE *buffer-size*)] - (loop [] - (let [size (.read input buffer)] - (when (pos? size) - (let [bytes (.getBytes (String. buffer 0 size) *default-encoding*)] - (do (.write output bytes) - (recur)))))))) - -(defmethod copy [Reader Writer] [#^Reader input #^Writer output] - (let [#^"[C" buffer (make-array Character/TYPE *buffer-size*)] - (loop [] - (let [size (.read input buffer)] - (when (pos? size) - (do (.write output buffer 0 size) - (recur))))))) - -(defmethod copy [Reader File] [#^Reader input #^File output] - (with-open [out (FileOutputStream. output)] - (copy input out))) - -(defmethod copy [File OutputStream] [#^File input #^OutputStream output] - (with-open [in (FileInputStream. input)] - (copy in output))) - -(defmethod copy [File Writer] [#^File input #^Writer output] - (with-open [in (FileInputStream. input)] - (copy in output))) - -(defmethod copy [File File] [#^File input #^File output] - (with-open [in (FileInputStream. input) - out (FileOutputStream. output)] - (copy in out))) - -(defmethod copy [String OutputStream] [#^String input #^OutputStream output] - (copy (StringReader. input) output)) - -(defmethod copy [String Writer] [#^String input #^Writer output] - (copy (StringReader. input) output)) - -(defmethod copy [String File] [#^String input #^File output] - (copy (StringReader. input) output)) - -(defmethod copy [*byte-array-type* OutputStream] [#^"[B" input #^OutputStream output] - (copy (ByteArrayInputStream. input) output)) - -(defmethod copy [*byte-array-type* Writer] [#^"[B" input #^Writer output] - (copy (ByteArrayInputStream. input) output)) - -(defmethod copy [*byte-array-type* File] [#^"[B" input #^Writer output] - (copy (ByteArrayInputStream. input) output)) - - -(defn make-parents - "Creates all parent directories of file." - [#^File file] - (.mkdirs (.getParentFile file))) - -(defmulti - #^{:doc "Converts argument into a Java byte array. Argument may be - a String, File, InputStream, or Reader. If the argument is already - a byte array, returns it." - :arglists '([arg])} - to-byte-array type) - -(defmethod to-byte-array *byte-array-type* [x] x) - -(defmethod to-byte-array String [#^String x] - (.getBytes x *default-encoding*)) - -(defmethod to-byte-array File [#^File x] - (with-open [input (FileInputStream. x) - buffer (ByteArrayOutputStream.)] - (copy input buffer) - (.toByteArray buffer))) - -(defmethod to-byte-array InputStream [#^InputStream x] - (let [buffer (ByteArrayOutputStream.)] - (copy x buffer) - (.toByteArray buffer))) - -(defmethod to-byte-array Reader [#^Reader x] - (.getBytes (slurp* x) *default-encoding*)) - diff --git a/src/clojure/contrib/error_kit.clj b/src/clojure/contrib/error_kit.clj deleted file mode 100644 index 93ebddd4..00000000 --- a/src/clojure/contrib/error_kit.clj +++ /dev/null @@ -1,289 +0,0 @@ -; Copyright (c) Chris Houser, 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. - -; == EXPERIMENTAL == -; System for defining and using custom errors -; Please contact Chouser if you have any suggestions for better names -; or API adjustments. - -(ns - #^{:author "Chris Houser", - :doc "EXPERIMENTAL -System for defining and using custom errors -Please contact Chouser if you have any suggestions for better names -or API adjustments."} - clojure.contrib.error-kit - (:use [clojure.contrib.def :only (defvar defvar-)] - [clojure.stacktrace :only (root-cause)])) - -(defn- make-ctrl-exception [msg data] - "Create an exception object with associated data, used for passing - control and data to a dynamically containing handler." - (proxy [Error clojure.lang.IDeref] [msg] - (toString [] (str "Error Kit Control Exception: " msg ", " (pr-str data))) - (deref [] data))) - -(defvar- ctrl-exception-class - (class (make-ctrl-exception nil nil))) - -(defvar- *handler-stack* () "Stack of bound handler symbols") - -(defvar- *continues* {} "Map of currently available continue forms") - - -(defmacro throw-msg - "Returns a function that throws a Java Exception with the given - name. Useful to associate a new error-kit error type with a - particular Java Exception class, via the :unhandled error key." - [class-name] - `(fn [x#] (throw (new ~class-name (:msg x#))))) - -(defn error - "Base type for all error-kit errors" - {::args [:msg :unhandled :tag]} - [details] - (merge {:tag `error :msg "exception via error-kit" - :unhandled (throw-msg Exception)} - details)) - -(defn- qualify-sym [sym] - (let [v (resolve sym)] - (assert v) - (apply symbol (map #(str (% (meta v))) [:ns :name])))) - -(defmacro deferror - "Define a new error type" - {:arglists '([name [parent-error?] doc-string? [args*] & body] - [name [parent-error?] doc-string? args-destruct-map & body])} - [err-name pvec & decl] - (let [pvec (if (empty? pvec) [`error] pvec) - [docstr args & body] (if (string? (first decl)) decl (cons nil decl)) - args (or args []) - argmap (if (vector? args) `{:keys ~args} args) - body (or body {}) - qual-err-name (symbol (str *ns*) (name err-name))] - (assert (== (count pvec) 1)) ; only support single-inheritance for now - (assert (vector? args)) ; only vector (keyword destruct) args for now - `(do - (defn ~err-name [details#] - (let [basedata# ((resolve (first (parents '~qual-err-name))) details#) - ~argmap basedata#] - (merge basedata# {:tag '~qual-err-name} (do ~@body) details#))) - (alter-meta! (var ~err-name) assoc - :doc ~docstr ::args ~(vec (map #(keyword (str %)) args))) - ~@(for [parent pvec] - `(derive '~qual-err-name '~(qualify-sym parent))) - (var ~err-name)))) - -(defn- throw-to [msg target-map args] - (throw (make-ctrl-exception msg (assoc target-map :args args)))) - -(defn raise* - "Raise the given error object, best if created by an error - constructor defined with deferror. See also 'raise' macro." - [err] - (let [err-tag (:tag err)] - (loop [hs *handler-stack*] - (if (empty? hs) - ((:unhandled err) err) - (let [[{:keys [htag] :as handler}] hs] - (if (and htag (not (isa? err-tag htag))) - (recur (next hs)) - (let [rtn ((:hfunc handler) err)] - (if-not (vector? rtn) - (throw-to "default" handler (list rtn)) - (condp = (rtn 0) - ::continue-with (rtn 1) - ::continue (if-let [continue (*continues* (rtn 1))] - (throw-to "continue" continue (rtn 2)) - (do (prn *continues*) (throw - (Exception. - (str "Unbound continue name " (rtn 1)))))) - ::do-not-handle (recur (next hs)) - (throw-to "do-not-handle" handler (list rtn))))))))))) - -(defmacro raise - "Raise an error of the type err-name, constructed with the given args" - [err-name & args] - `(raise* (~err-name ~(zipmap (::args (meta (resolve err-name))) - args)))) - -; It'd be nice to assert that these are used in a tail position of a handler -(defmacro do-not-handle - "Use in a tail position of a 'handle' form to indicate 'raise' should - not consider the error handled, but should continue searching for an - appropriate 'handle' form. Allows finer-grain control over catching - than just the error type." - [] - `[::do-not-handle]) - -(defmacro continue-with [value] - "Use in a tail position of a 'handle' form to cause the currently - running 'raise' to return the given 'value'." - `[::continue-with ~value]) - -(defmacro continue [continue-name & args] - "Use in a tail position of a 'handle' form to pass control to the - named 'continue' form, passing in the given args. The 'continue' - form with the given name and the smallest dynamic scope surrounding - the currently running 'raise' will be used." - `[::continue '~continue-name [~@args]]) - - -(def #^{:doc "Special form to be used inside a 'with-handler'. When - any error is 'raised' from withing the dynamic scope of 'body' that - is of error-name's type or a derived type, the args will be bound - and the body executed. If no 'error-name' is given, the body will - be executed for regardless of the type of error raised. The body - may return a value, in which case that will be the return value of - the entire 'with-handler' form, or it may use any of the special - return forms, 'do-not-handle', 'continue-with', or 'continue'." - :arglists '([error-name? [args*] & body] - [error-name? args-destruct-map-args & body])} - handle) - -(def #^{:doc "Special form to be used inside a 'with-handler'. - Control can be passed to this 'continue' form from a 'raise' enclosed - in this with-handler's dynamic scope, when this 'continue-name' is - given to a 'continue' form." - :arglists '([continue-name [args*] & body])} - bind-continue) - -(defn- special-form [form] - (and (list form) - (symbol? (first form)) - (#{#'handle #'bind-continue} (resolve (first form))))) - - -(defmacro with-handler - "This is error-kit's dynamic scope form. The body will be executed - in a dynamic context that includes all of the following 'handle' and - 'bind-continue' forms." - [& forms] - (let [[body special-forms] (split-with (complement special-form) forms)] - (assert (every? special-form special-forms)) - (let [blockid (gensym) - handlers (for [[type & more] special-forms - :when (= (resolve type) #'handle)] - (let [[htag args & hbody] (if (symbol? (first more)) - more - (cons nil more)) - argmap (if (vector? args) `{:keys ~args} args)] - `{:blockid '~blockid - :htag ~(when htag (list `quote (qualify-sym htag))) - :hfunc (fn [~argmap] ~@hbody) - :rfunc identity})) - continues (into {} - (for [[type & more] special-forms - :when (= (resolve type) #'bind-continue)] - [(list `quote (first more)) - `{:blockid '~blockid - :rfunc (fn ~@(next more))}]))] - `(try - (binding [*handler-stack* (list* ~@handlers @#'*handler-stack*) - *continues* (merge @#'*continues* ~@continues)] - ~@body) - (catch Throwable e# - (let [root-cause# (root-cause e#)] - (if-not (instance? @#'ctrl-exception-class root-cause#) - (throw e#) - (let [data# @root-cause#] - (if (= '~blockid (:blockid data#)) - (apply (:rfunc data#) (:args data#)) - (throw e#)))))))))) - -(defn rebind-fn [func] - (let [a *handler-stack*, b *continues*] - (fn [& args] - (binding [*handler-stack* a - *continues* b] - (apply func args))))) - -(comment - -(alias 'kit 'clojure.contrib.error-kit) - -; This defines an error and its action if unhandled. A good choice of -; unhandled. action is to throw a Java exception so users of your code -; who do not want to use error-kit can still use normal Java try/catch -; forms to handle the error. -(kit/deferror number-error [] [n] - {:msg (str "Number error: " n) - :unhandled (kit/throw-msg NumberFormatException)}) - -(kit/deferror odd-number-error [number-error] - "Indicates an odd number was given to an operation that is only - defined for even numbers." - [n] - {:msg (str "Can't handle odd number: " n)}) - -; Raise an error by name with any extra args defined by the deferror -(defn int-half [i] - (if (even? i) - (quot i 2) - (kit/raise odd-number-error i))) - -; Throws Java NumberFormatException because there's no 'handle' form -(vec (map int-half [2 4 5 8])) - -; Throws Java Exception with details provided by 'raise' -(kit/with-handler - (vec (map int-half [2 4 5 8])) - (kit/handle odd-number-error [n] - (throw (Exception. (format "Odd number %d in vector." n))))) - -; The above is equivalent to the more complicated version below: -(kit/with-handler - (vec (map int-half [2 4 5 8])) - (kit/handle {:keys [n tag]} - (if (isa? tag `odd-number-error) - (throw (Exception. (format "Odd number %d in vector." n))) - (kit/do-not-handle)))) - -; Returns "invalid" string instead of a vector when an error is encountered -(kit/with-handler - (vec (map int-half [2 4 5 8])) - (kit/handle kit/error [n] - "invalid")) - -; Inserts a zero into the returned vector where there was an error, in -; this case [1 2 0 4] -(kit/with-handler - (vec (map int-half [2 4 5 8])) - (kit/handle number-error [n] - (kit/continue-with 0))) - -; Intermediate continue: [1 2 :oops 5 4] -(defn int-half-vec [s] - (reduce (fn [v i] - (kit/with-handler - (conj v (int-half i)) - (kit/bind-continue instead-of-half [& instead-seq] - (apply conj v instead-seq)))) - [] s)) - -(kit/with-handler - (int-half-vec [2 4 5 8]) - (kit/handle number-error [n] - (kit/continue instead-of-half :oops n))) - -; Notes: - -; It seems likely you'd want to convert a handle clause to -; bind-continue, since it would allow higher forms to request what you -; used to do by default. Thus both should appear in the same -; with-handler form - -; Should continue-names be namespace qualified, and therefore require -; pre-definition in some namespace? -; (kit/defcontinue skip-thing "docstring") - -; Could add 'catch' for Java Exceptions and 'finally' support to -; with-handler forms. - -) diff --git a/src/clojure/contrib/except.clj b/src/clojure/contrib/except.clj deleted file mode 100644 index 93153342..00000000 --- a/src/clojure/contrib/except.clj +++ /dev/null @@ -1,95 +0,0 @@ -;; Copyright (c) Stephen C. Gilardi. 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. -;; -;; except.clj -;; -;; Provides functions that make it easy to specify the class, cause, and -;; message when throwing an Exception or Error. The optional message is -;; formatted using clojure.core/format. -;; -;; scgilardi (gmail) -;; Created 07 July 2008 - -(ns - #^{:author "Stephen C. Gilardi", - :doc "Provides functions that make it easy to specify the class, cause, and -message when throwing an Exception or Error. The optional message is -formatted using clojure.core/format."} - clojure.contrib.except - (:import (clojure.lang Reflector))) - -(declare throwable) - -(defn throwf - "Throws an Exception or Error with an optional message formatted using - clojure.core/format. All arguments are optional: - - class? cause? format? format-args* - - - class defaults to Exception, if present it must name a kind of - Throwable - - cause defaults to nil, if present it must be a Throwable - - format is a format string for clojure.core/format - - format-args are objects that correspond to format specifiers in - format." - [& args] - (throw (throwable args))) - -(defn throw-if - "Throws an Exception or Error if test is true. args are those documented - for throwf." - [test & args] - (when test - (throw (throwable args)))) - -(defn throw-if-not - "Throws an Exception or Error if test is false. args are those documented - for throwf." - [test & args] - (when-not test - (throw (throwable args)))) - -(defn throw-arg - "Throws an IllegalArgumentException. All arguments are optional: - - cause? format? format-args* - - - cause defaults to nil, if present it must be a Throwable - - format is a format string for clojure.core/format - - format-args are objects that correspond to format specifiers in - format." - [& args] - (throw (throwable (cons IllegalArgumentException args)))) - -(defn- throwable? - "Returns true if x is a Throwable" - [x] - (instance? Throwable x)) - -(defn- throwable - "Constructs a Throwable with optional cause and formatted message. Its - stack trace will begin with our caller's caller. Args are as described - for throwf except throwable accepts them as list rather than inline." - [args] - (let [[arg] args - [class & args] (if (class? arg) args (cons Exception args)) - [arg] args - [cause & args] (if (throwable? arg) args (cons nil args)) - message (when args (apply format args)) - ctor-args (into-array Object - (cond (and message cause) [message cause] - message [message] - cause [cause])) - throwable (Reflector/invokeConstructor class ctor-args) - our-prefix "clojure.contrib.except$throwable" - not-us? #(not (.startsWith (.getClassName %) our-prefix)) - raw-trace (.getStackTrace throwable) - edited-trace (into-array StackTraceElement - (drop 3 (drop-while not-us? raw-trace)))] - (.setStackTrace throwable edited-trace) - throwable)) diff --git a/src/clojure/contrib/fcase.clj b/src/clojure/contrib/fcase.clj deleted file mode 100644 index 62a49da0..00000000 --- a/src/clojure/contrib/fcase.clj +++ /dev/null @@ -1,108 +0,0 @@ -;;; fcase.clj -- simple variants of "case" for Clojure - -;; by Stuart Sierra, http://stuartsierra.com/ -;; April 7, 2008 - -;; Copyright (c) Stuart Sierra, 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 file defines a generic "case" macro called "fcase" which takes -;; the equality-testing function as an argument. It also defines a -;; traditional "case" macro that tests using "=" and variants that -;; test for regular expressions and class membership. - - -;; Note (December 23, 2008): This library has been supplanted by the -;; inclusion of "condp" in clojure.core as of Clojure SVN rev. 1180. - - -(ns - #^{:author "Stuart Sierra", - :doc "This file defines a generic \"case\" macro called \"fcase\" which takes -the equality-testing function as an argument. It also defines a -traditional \"case\" macro that tests using \"=\" and variants that -test for regular expressions and class membership. - - -Note (December 23, 2008): This library has been supplanted by the -inclusion of \"condp\" in clojure.core as of Clojure SVN rev. 1180."} - - clojure.contrib.fcase - (:refer-clojure :exclude (case))) - - -(defmacro fcase - "Generic switch/case macro. 'fcase' is short for 'function case'. - - The 'compare-fn' is a fn of two arguments. - - The 'test-expr-clauses' are value-expression pairs without - surrounding parentheses, like in Clojure's 'cond'. - - The 'case-value' is evaluated once and cached. Then, 'compare-fn' - is called once for each clause, with the clause's test value as its - first argument and 'case-value' as its second argument. If - 'compare-fn' returns logical true, the clause's expression is - evaluated and returned. If 'compare-fn' returns false/nil, we go to - the next test value. - - If 'test-expr-clauses' contains an odd number of items, the last - item is the default expression evaluated if no case-value matches. - If there is no default expression and no case-value matches, fcase - returns nil. - - See specific forms of this macro in 'case' and 're-case'. - - The test expressions in 'fcase' are always evaluated linearly, in - order. For a large number of case expressions it may be more - efficient to use a hash lookup." - [compare-fn case-value & - test-expr-clauses] - (let [test-val-sym (gensym "test_val") - test-fn-sym (gensym "test_fn") - cond-loop (fn this [clauses] - (cond - (>= (count clauses) 2) - (list 'if (list test-fn-sym (first clauses) test-val-sym) - (second clauses) - (this (rest (rest clauses)))) - (= (count clauses) 1) (first clauses)))] - (list 'let [test-val-sym case-value, test-fn-sym compare-fn] - (cond-loop test-expr-clauses)))) - -(defmacro case - "Like cond, but test-value is compared against the value of each - test expression with =. If they are equal, executes the \"body\" - expression. Optional last expression is executed if none of the - test expressions match." - [test-value & clauses] - `(fcase = ~test-value ~@clauses)) - -(defmacro re-case - "Like case, but the test expressions are regular expressions, tested - with re-find." - [test-value & clauses] - `(fcase re-find ~test-value ~@clauses)) - -(defmacro instance-case - "Like case, but the test expressions are Java class names, tested with - 'instance?'." - [test-value & clauses] - `(fcase instance? ~test-value ~@clauses)) - -(defn in-case-test [test-seq case-value] - (some (fn [item] (= item case-value)) - test-seq)) - -(defmacro in-case - "Like case, but test expressions are sequences. The test expression - is true if any item in the sequence is equal (tested with '=') to - the test value." - [test-value & clauses] - `(fcase in-case-test ~test-value ~@clauses)) diff --git a/src/clojure/contrib/find_namespaces.clj b/src/clojure/contrib/find_namespaces.clj deleted file mode 100644 index 174820d4..00000000 --- a/src/clojure/contrib/find_namespaces.clj +++ /dev/null @@ -1,136 +0,0 @@ -;;; find_namespaces.clj: search for ns declarations in dirs, JARs, or CLASSPATH - -;; by Stuart Sierra, http://stuartsierra.com/ -;; April 19, 2009 - -;; Copyright (c) Stuart Sierra, 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. - - -(ns - #^{:author "Stuart Sierra", - :doc "Search for ns declarations in dirs, JARs, or CLASSPATH"} - clojure.contrib.find-namespaces - (:require [clojure.contrib.classpath :as cp] - [clojure.contrib.jar :as jar]) - (import (java.io File FileReader BufferedReader PushbackReader - InputStreamReader) - (java.util.jar JarFile))) - - -;;; Finding namespaces in a directory tree - -(defn clojure-source-file? - "Returns true if file is a normal file with a .clj extension." - [#^File file] - (and (.isFile file) - (.endsWith (.getName file) ".clj"))) - -(defn find-clojure-sources-in-dir - "Searches recursively under dir for Clojure source files (.clj). - Returns a sequence of File objects, in breadth-first sort order." - [#^File dir] - ;; Use sort by absolute path to get breadth-first search. - (sort-by #(.getAbsolutePath %) - (filter clojure-source-file? (file-seq dir)))) - -(defn comment? - "Returns true if form is a (comment ...)" - [form] - (and (list? form) (= 'comment (first form)))) - -(defn ns-decl? - "Returns true if form is a (ns ...) declaration." - [form] - (and (list? form) (= 'ns (first form)))) - -(defn read-ns-decl - "Attempts to read a (ns ...) declaration from rdr, and returns the - unevaluated form. Returns nil if read fails or if a ns declaration - cannot be found. The ns declaration must be the first Clojure form - in the file, except for (comment ...) forms." - [#^PushbackReader rdr] - (try (let [form (read rdr)] - (cond - (ns-decl? form) form - (comment? form) (recur rdr) - :else nil)) - (catch Exception e nil))) - -(defn read-file-ns-decl - "Attempts to read a (ns ...) declaration from file, and returns the - unevaluated form. Returns nil if read fails, or if the first form - is not a ns declaration." - [#^File file] - (with-open [rdr (PushbackReader. (BufferedReader. (FileReader. file)))] - (read-ns-decl rdr))) - -(defn find-ns-decls-in-dir - "Searches dir recursively for (ns ...) declarations in Clojure - source files; returns the unevaluated ns declarations." - [#^File dir] - (filter identity (map read-file-ns-decl (find-clojure-sources-in-dir dir)))) - -(defn find-namespaces-in-dir - "Searches dir recursively for (ns ...) declarations in Clojure - source files; returns the symbol names of the declared namespaces." - [#^File dir] - (map second (find-ns-decls-in-dir dir))) - - -;;; Finding namespaces in JAR files - -(defn clojure-sources-in-jar - "Returns a sequence of filenames ending in .clj found in the JAR file." - [#^JarFile jar-file] - (filter #(.endsWith % ".clj") (jar/filenames-in-jar jar-file))) - -(defn read-ns-decl-from-jarfile-entry - "Attempts to read a (ns ...) declaration from the named entry in the - JAR file, and returns the unevaluated form. Returns nil if the read - fails, or if the first form is not a ns declaration." - [#^JarFile jarfile #^String entry-name] - (with-open [rdr (PushbackReader. - (BufferedReader. - (InputStreamReader. - (.getInputStream jarfile (.getEntry jarfile entry-name)))))] - (read-ns-decl rdr))) - -(defn find-ns-decls-in-jarfile - "Searches the JAR file for Clojure source files containing (ns ...) - declarations; returns the unevaluated ns declarations." - [#^JarFile jarfile] - (filter identity - (map #(read-ns-decl-from-jarfile-entry jarfile %) - (clojure-sources-in-jar jarfile)))) - -(defn find-namespaces-in-jarfile - "Searches the JAR file for Clojure source files containing (ns ...) - declarations. Returns a sequence of the symbol names of the - declared namespaces." - [#^JarFile jarfile] - (map second (find-ns-decls-in-jarfile jarfile))) - - -;;; Finding namespaces anywhere on CLASSPATH - -(defn find-ns-decls-on-classpath - "Searches CLASSPATH (both directories and JAR files) for Clojure - source files containing (ns ...) declarations. Returns a sequence - of the unevaluated ns declaration forms." - [] - (concat - (mapcat find-ns-decls-in-dir (cp/classpath-directories)) - (mapcat find-ns-decls-in-jarfile (cp/classpath-jarfiles)))) - -(defn find-namespaces-on-classpath - "Searches CLASSPATH (both directories and JAR files) for Clojure - source files containing (ns ...) declarations. Returns a sequence - of the symbol names of the declared namespaces." - [] - (map second (find-ns-decls-on-classpath))) diff --git a/src/clojure/contrib/fnmap.clj b/src/clojure/contrib/fnmap.clj deleted file mode 100644 index f9cfc7c5..00000000 --- a/src/clojure/contrib/fnmap.clj +++ /dev/null @@ -1,36 +0,0 @@ -;;; fnmap.clj: maps that dispatch get/assoc to functions - -;; Copyright (c) Stuart Sierra, 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. - - -(ns #^{:author "Stuart Sierra" - :doc "Maps that dispatch get/assoc to user-defined functions. - - Note: requires AOT-compilation"} - clojure.contrib.fnmap - (:require clojure.contrib.fnmap.PersistentFnMap)) - -(defn fnmap - "Creates a fnmap, or functional map. A fnmap behaves like an - ordinary Clojure map, except that calls to get and assoc are - filtered through user-defined getter and setter functions, which - operate on an internal map. - - (getter m key) should return a value for key. - - (setter m key value) should assoc key with value and return a new - map for m. - - All other map operations are passed through to the internal map." - ([getter setter] (clojure.contrib.fnmap.PersistentFnMap/create getter setter)) - ([getter setter & keyvals] - (apply assoc - (clojure.contrib.fnmap.PersistentFnMap/create getter setter) - keyvals))) - diff --git a/src/clojure/contrib/fnmap/PersistentFnMap.clj b/src/clojure/contrib/fnmap/PersistentFnMap.clj deleted file mode 100644 index dfa3af64..00000000 --- a/src/clojure/contrib/fnmap/PersistentFnMap.clj +++ /dev/null @@ -1,70 +0,0 @@ -;; PersistentFnMap.clj: implementation for clojure.contrib.fnmap - -;; Copyright (c) Stuart Sierra, 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. - - -;; Thanks to Meikel Brandmeyer for his work on lazymap, which made -;; this implementation easier. - - -(ns clojure.contrib.fnmap.PersistentFnMap - (:gen-class :extends clojure.lang.APersistentMap - :state state - :init init - :constructors {[clojure.lang.IPersistentMap] [], - [clojure.lang.IPersistentMap clojure.lang.IPersistentMap] [clojure.lang.IPersistentMap]})) - -(defn -init - ([theMap] [[] theMap]) - ([theMap metadata] [[metadata] theMap])) - -(defn create [getter setter] - (clojure.contrib.fnmap.PersistentFnMap. - {::getter getter ::setter setter})) - -;; IPersistentMap - -(defn -assoc [this key value] - (clojure.contrib.fnmap.PersistentFnMap. - ((::setter (. this state)) (. this state) key value))) - -;; Associative - -(defn- -containsKey [this key] - (not (nil? ((::getter (. this state)) this key)))) - -(defn- -entryAt [this key] - (clojure.lang.MapEntry. key ((::getter (. this state)) (. this state) key))) - -(defn -valAt - ([this key] - ((::getter (. this state)) (. this state) key)) - ([this key default] - (or ((::getter (. this state)) (. this state) key) - default))) - -;; Iterable - -(defn -iterator [this] - (.. this state iterator)) - -;; IPersistentCollection - -(defn -count [this] - (count (. this state))) - -(defn -seq [this] - (seq (. this state))) - -(defn -cons [this that] - (.. this state (cons this that))) - -(defn -empty [this] - (.. this state empty)) - diff --git a/src/clojure/contrib/gen_html_docs.clj b/src/clojure/contrib/gen_html_docs.clj deleted file mode 100644 index 364d4279..00000000 --- a/src/clojure/contrib/gen_html_docs.clj +++ /dev/null @@ -1,539 +0,0 @@ -;;; gen-html-docs.clj: Generate HTML documentation for Clojure libs - -;; by Craig Andera, http://pluralsight.com/craig, candera@wangdera.com -;; February 13th, 2009 - -;; Copyright (c) Craig Andera, 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. - -;; Generates a single HTML page that contains the documentation for -;; one or more Clojure libraries. See the comments section at the end -;; of this file for usage. - -;; TODO -;; -;; * Make symbols in the source hyperlinks to the appropriate section -;; of the documentation. -;; * Investigate issue with miglayout mentioned here: -;; http://groups.google.com/group/clojure/browse_thread/thread/5a0c4395e44f5a79/3ae483100366bd3d?lnk=gst&q=documentation+browser#3ae483100366bd3d -;; -;; DONE -;; -;; * Move to clojure.contrib -;; * Change namespace -;; * Change license as appropriate -;; * Double-check doc strings -;; * Remove doc strings from source code -;; * Add collapse/expand functionality for all namespaces -;; * Add collapse/expand functionality for each namespace -;; * See if converting to use clojure.contrib.prxml is possible -;; * Figure out why the source doesn't show up for most things -;; * Add collapsible source -;; * Add links at the top to jump to each namespace -;; * Add object type (var, function, whatever) -;; * Add argument lists for functions -;; * Add links at the top of each namespace to jump to members -;; * Add license statement -;; * Remove the whojure dependency - -(ns - #^{:author "Craig Andera", - :doc "Generates a single HTML page that contains the documentation for -one or more Clojure libraries."} - clojure.contrib.gen-html-docs - (:require [clojure.contrib.duck-streams :as duck-streams]) - (:use [clojure.contrib seq-utils str-utils repl-utils def prxml]) - (:import [java.lang Exception] - [java.util.regex Pattern])) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Doc generation constants -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(def *script* " // <![CDATA[ - -function getElem(id) -{ - if( document.getElementById ) - { - return document.getElementById( id ) - } - else if ( document.all ) - { - return eval( 'document.all.' + id ) - } - else - return false; -} - -function setDisplayStyle(id,displayStyle) -{ - var elem = getElem (id) - if (elem) - { - elem.style.display = displayStyle - } - -} - -function setLinkToggleText (id, text) -{ - var elem = getElem (id) - if (elem) - { - elem.innerHTML = text - } -} - -function collapse(id) -{ - setDisplayStyle (id, 'none') -} - -function expand (id) -{ - setDisplayStyle (id, 'block') -} - -function toggleSource( id ) -{ - toggle(id, 'linkto-' + id, 'Hide Source', 'Show Source') -} - -function toggle(targetid, linkid, textWhenOpen, textWhenClosed) -{ - var elem = getElem (targetid) - var link = getElem (linkid) - - if (elem && link) - { - var isOpen = false - if (elem.style.display == '') - { - isOpen = link.innerHTML == textWhenOpen - } - else if( elem.style.display == 'block' ) - { - isOpen = true - } - - if (isOpen) - { - elem.style.display = 'none' - link.innerHTML = textWhenClosed - } - else - { - elem.style.display = 'block' - link.innerHTML = textWhenOpen - } - } -} - - //]]> -") - -(def *style* " -.library -{ - padding: 0.5em 0 0 0 -} -.all-libs-toggle,.library-contents-toggle -{ - font-size: small; -} -.all-libs-toggle a,.library-contents-toggle a -{ - color: white -} -.library-member-doc-whitespace -{ - white-space: pre -} -.library-member-source-toggle -{ - font-size: small; - margin-top: 0.5em -} -.library-member-source -{ - display: none; - border-left: solid lightblue -} -.library-member-docs -{ - font-family:monospace -} -.library-member-arglists -{ - font-family: monospace -} -.library-member-type -{ - font-weight: bold; - font-size: small; - font-style: italic; - color: darkred -} -.lib-links -{ - margin: 0 0 1em 0 -} - -.lib-link-header -{ - color: white; - background: darkgreen; - width: 100% -} - -.library-name -{ - color: white; - background: darkblue; - width: 100% -} - -.missing-library -{ - color: darkred; - margin: 0 0 1em 0 -} - -.library-members -{ - list-style: none -} - -.library-member-name -{ - font-weight: bold; - font-size: 105% -}") - -(defn- extract-documentation - "Pulls the documentation for a var v out and turns it into HTML" - [v] - (if-let [docs (:doc (meta v))] - (map - (fn [l] - [:div {:class "library-member-doc-line"} - (if (= 0 (count l)) - [:span {:class "library-member-doc-whitespace"} " "] ; We need something here to make the blank line show up - l)]) - (re-split #"\n" docs)) - "")) - -(defn- member-type - "Figures out for a var x whether it's a macro, function, var or multifunction" - [x] - (try - (let [dx (deref x)] - (cond - (:macro (meta x)) :macro - (fn? dx) :fn - (= clojure.lang.MultiFn (:tag (meta x))) :multi - true :var)) - (catch Exception e - :unknown))) - -(defn- anchor-for-member - "Returns a suitable HTML anchor name given a library id and a member - id" - [libid memberid] - (str "member-" libid "-" memberid)) - -(defn- id-for-member-source - "Returns a suitable HTML id for a source listing given a library and - a member" - [libid memberid] - (str "membersource-" libid "-" memberid)) - -(defn- id-for-member-source-link - "Returns a suitable HTML id for a link to a source listing given a - library and a member" - [libid memberid] - (str "linkto-membersource-" libid "-" memberid)) - -(defn- symbol-for - "Given a namespace object ns and a namespaceless symbol memberid - naming a member of that namespace, returns a namespaced symbol that - identifies that member." - [ns memberid] - (symbol (name (ns-name ns)) (name memberid))) - -(defn- elide-to-one-line - "Elides a string down to one line." - [s] - (re-sub #"(\n.*)+" "..." s)) - -(defn- elide-string - "Returns a string that is at most the first limit characters of s" - [s limit] - (if (< (- limit 3) (count s)) - (str (subs s 0 (- limit 3)) "...") - s)) - -(defn- doc-elided-src - "Returns the src with the docs elided." - [docs src] - (re-sub (re-pattern (str "\"" (Pattern/quote docs) "\"")) - (str "\"" - (elide-to-one-line docs) -;; (elide-string docs 10) -;; "..." - "\"") - src)) - -(defn- format-source [libid memberid v] - (try - (let [docs (:doc (meta v)) - src (if-let [ns (find-ns libid)] - (get-source (symbol-for ns memberid)))] - (if (and src docs) - (doc-elided-src docs src) - src)) - (catch Exception ex - nil))) - -(defn- generate-lib-member [libid [n v]] - [:li {:class "library-member"} - [:a {:name (anchor-for-member libid n)}] - [:dl {:class "library-member-table"} - [:dt {:class "library-member-name"} - (str n)] - [:dd - [:div {:class "library-member-info"} - [:span {:class "library-member-type"} (name (member-type v))] - " " - [:span {:class "library-member-arglists"} (str (:arglists (meta v)))]] - (into [:div {:class "library-member-docs"}] (extract-documentation v)) - (let [member-source-id (id-for-member-source libid n) - member-source-link-id (id-for-member-source-link libid n)] - (if-let [member-source (format-source libid n v)] - [:div {:class "library-member-source-section"} - [:div {:class "library-member-source-toggle"} - "[ " - [:a {:href (format "javascript:toggleSource('%s')" member-source-id) - :id member-source-link-id} "Show Source"] - " ]"] - [:div {:class "library-member-source" :id member-source-id} - [:pre member-source]]]))]]]) - -(defn- anchor-for-library - "Given a symbol id identifying a namespace, returns an identifier -suitable for use as the name attribute of an HTML anchor tag." - [id] - (str "library-" id)) - -(defn- generate-lib-member-link - "Emits a hyperlink to a member of a namespace given libid (a symbol -identifying the namespace) and the vector [n v], where n is the symbol -naming the member in question and v is the var pointing to the -member." - [libid [n v]] - [:a {:class "lib-member-link" - :href (str "#" (anchor-for-member libid n))} (name n)]) - -(defn- anchor-for-library-contents - "Returns an HTML ID that identifies the element that holds the -documentation contents for the specified library." - [lib] - (str "library-contents-" lib)) - -(defn- anchor-for-library-contents-toggle - "Returns an HTML ID that identifies the element that toggles the -visibility of the library contents." - [lib] - (str "library-contents-toggle-" lib)) - -(defn- generate-lib-doc - "Emits the HTML that documents the namespace identified by the -symbol lib." - [lib] - [:div {:class "library"} - [:a {:name (anchor-for-library lib)}] - [:div {:class "library-name"} - [:span {:class "library-contents-toggle"} - "[ " - [:a {:id (anchor-for-library-contents-toggle lib) - :href (format "javascript:toggle('%s', '%s', '-', '+')" - (anchor-for-library-contents lib) - (anchor-for-library-contents-toggle lib))} - "-"] - " ] "] - (name lib)] - (let [ns (find-ns lib)] - (if ns - (let [lib-members (sort (ns-publics ns))] - [:a {:name (anchor-for-library lib)}] - [:div {:class "library-contents" :id (anchor-for-library-contents lib)} - (into [:div {:class "library-member-links"}] - (interpose " " (map #(generate-lib-member-link lib %) lib-members))) - (into [:ol {:class "library-members"}] - (map #(generate-lib-member lib %) lib-members))]) - [:div {:class "missing-library library-contents" :id (anchor-for-library-contents lib)} "Could not load library"]))]) - -(defn- load-lib - "Calls require on the library identified by lib, eating any -exceptions." - [lib] - (try - (require lib) - (catch java.lang.Exception x - nil))) - -(defn- generate-lib-link - "Generates a hyperlink to the documentation for a namespace given -lib, a symbol identifying that namespace." - [lib] - (let [ns (find-ns lib)] - (if ns - [:a {:class "lib-link" :href (str "#" (anchor-for-library lib))} (str (ns-name ns))]))) - -(defn- generate-lib-links - "Generates the list of hyperlinks to each namespace, given libs, a -vector of symbols naming namespaces." - [libs] - (into [:div {:class "lib-links"} - [:div {:class "lib-link-header"} "Namespaces" - [:span {:class "all-libs-toggle"} - " [ " - [:a {:href "javascript:expandAllNamespaces()"} - "Expand All"] - " ] [ " - [:a {:href "javascript:collapseAllNamespaces()"} - "Collapse All"] - " ]"]]] - (interpose " " (map generate-lib-link libs)))) - -(defn generate-toggle-namespace-script - [action toggle-text lib] - (str (format "%s('%s');\n" action (anchor-for-library-contents lib)) - (format "setLinkToggleText('%s', '%s');\n" (anchor-for-library-contents-toggle lib) toggle-text))) - -(defn generate-all-namespaces-action-script - [action toggle-text libs] - (str (format "function %sAllNamespaces()" action) - \newline - "{" - \newline - (reduce str (map #(generate-toggle-namespace-script action toggle-text %) libs)) - \newline - "}")) - -(defn generate-documentation - "Returns a string which is the HTML documentation for the libraries -named by libs. Libs is a vector of symbols identifying Clojure -libraries." - [libs] - (dorun (map load-lib libs)) - (let [writer (new java.io.StringWriter)] - (binding [*out* writer] - (prxml - [:html {:xmlns "http://www.w3.org/1999/xhtml"} - [:head - [:title "Clojure documentation browser"] - [:style *style*] - [:script {:language "JavaScript" :type "text/javascript"} [:raw! *script*]] - - [:script {:language "JavaScript" :type "text/javascript"} - [:raw! "// <![CDATA[!" \newline] - (generate-all-namespaces-action-script "expand" "-" libs) - (generate-all-namespaces-action-script "collapse" "+" libs) - [:raw! \newline "// ]]>"]]] - (let [lib-vec (sort libs)] - (into [:body (generate-lib-links lib-vec)] - (map generate-lib-doc lib-vec)))])) - (.toString writer))) - - -(defn generate-documentation-to-file - "Calls generate-documentation on the libraries named by libs and -emits the generated HTML to the path named by path." - [path libs] - (duck-streams/spit path (generate-documentation libs))) - -(comment - (generate-documentation-to-file - "C:/TEMP/CLJ-DOCS.HTML" - ['clojure.contrib.accumulators]) - - (defn gen-all-docs [] - (generate-documentation-to-file - "C:/temp/clj-libs.html" - [ - 'clojure.set - 'clojure.main - 'clojure.core - 'clojure.zip - 'clojure.xml - 'clojure.contrib.accumulators - 'clojure.contrib.apply-macro - 'clojure.contrib.auto-agent - 'clojure.contrib.combinatorics - 'clojure.contrib.command-line - 'clojure.contrib.complex-numbers - 'clojure.contrib.cond - 'clojure.contrib.def - 'clojure.contrib.duck-streams - 'clojure.contrib.enum - 'clojure.contrib.error-kit - 'clojure.contrib.except - 'clojure.contrib.fcase - 'clojure.contrib.generic - 'clojure.contrib.generic.arithmetic - 'clojure.contrib.generic.collection - 'clojure.contrib.generic.comparison - 'clojure.contrib.generic.functor - 'clojure.contrib.generic.math-functions - 'clojure.contrib.import-static - 'clojure.contrib.javadoc - 'clojure.contrib.javalog - 'clojure.contrib.lazy-seqs - 'clojure.contrib.lazy-xml - 'clojure.contrib.macro-utils - 'clojure.contrib.macros - 'clojure.contrib.math - 'clojure.contrib.miglayout - 'clojure.contrib.mmap - 'clojure.contrib.monads - 'clojure.contrib.ns-utils - 'clojure.contrib.prxml - 'clojure.contrib.repl-ln - 'clojure.contrib.repl-utils - 'clojure.contrib.seq-utils - 'clojure.contrib.server-socket - 'clojure.contrib.shell-out - 'clojure.contrib.sql - 'clojure.contrib.stream-utils - 'clojure.contrib.str-utils - 'clojure.contrib.test-contrib - 'clojure.contrib.trace - 'clojure.contrib.types - 'clojure.contrib.zip-filter - 'clojure.contrib.javadoc.browse - 'clojure.contrib.json.read - 'clojure.contrib.json.write - 'clojure.contrib.lazy-xml.with-pull - 'clojure.contrib.miglayout.internal - 'clojure.contrib.probabilities.finite-distributions - 'clojure.contrib.probabilities.monte-carlo - 'clojure.contrib.probabilities.random-numbers - 'clojure.contrib.sql.internal - 'clojure.contrib.test-clojure.evaluation - 'clojure.contrib.test-clojure.for - 'clojure.contrib.test-clojure.numbers - 'clojure.contrib.test-clojure.printer - 'clojure.contrib.test-clojure.reader - 'clojure.contrib.test-clojure.sequences - 'clojure.contrib.test-contrib.shell-out - 'clojure.contrib.test-contrib.str-utils - 'clojure.contrib.zip-filter.xml - ])) - ) diff --git a/src/clojure/contrib/generic.clj b/src/clojure/contrib/generic.clj deleted file mode 100644 index dc4ef572..00000000 --- a/src/clojure/contrib/generic.clj +++ /dev/null @@ -1,54 +0,0 @@ -;; Support code for generic interfaces - -;; by Konrad Hinsen -;; last updated May 4, 2009 - -;; Copyright (c) Konrad Hinsen, 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. - -(ns - #^{:author "Konrad Hinsen" - :skip-wiki true - :doc "Generic interfaces - This library provides generic interfaces in the form of - multimethods that can be implemented for any type. - The interfaces partly duplicate existing non-generic - functions in clojure.core (arithmetic, comparison, - collections) and partly provide additional functions that - can be defined for a wide variety of types (functors, math - functions). More functions will be added in the future."} - clojure.contrib.generic - (:use [clojure.contrib.types :only (defadt)])) - -; -; A dispatch function that separates nulary, unary, binary, and -; higher arity calls and also selects on type for unary and binary -; calls. -; -(defn nary-dispatch - ([] ::nulary) - ([x] (type x)) - ([x y] - [(type x) (type y)]) - ([x y & more] ::nary)) - -; -; We can't use [::binary :default], so we need to define a root type -; of the type hierarcy. The derivation for Object covers all classes, -; but all non-class types will need an explicit derive clause. -; Ultimately, a macro might take care of this. -; -(def root-type ::any) -(derive Object root-type) - -; -; Symbols referring to ::nulary and ::n-ary -; -(def nulary-type ::nulary) -(def nary-type ::nary) - diff --git a/src/clojure/contrib/generic/arithmetic.clj b/src/clojure/contrib/generic/arithmetic.clj deleted file mode 100644 index 90b6e659..00000000 --- a/src/clojure/contrib/generic/arithmetic.clj +++ /dev/null @@ -1,201 +0,0 @@ -;; Generic interfaces for arithmetic operations - -;; by Konrad Hinsen -;; last updated May 5, 2009 - -;; Copyright (c) Konrad Hinsen, 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. - -(ns - #^{:author "Konrad Hinsen" - :doc "Generic arithmetic interface - This library defines generic versions of + - * / as multimethods - that can be defined for any type. The minimal required - implementations for a type are binary + and * plus unary - and /. - Everything else is derived from these automatically. Explicit - binary definitions for - and / can be provided for - efficiency reasons."} - clojure.contrib.generic.arithmetic - (:use [clojure.contrib.generic - :only (root-type nulary-type nary-type nary-dispatch)] - [clojure.contrib.types :only (defadt)]) - (:refer-clojure :exclude [+ - * /])) - -; -; Universal zero and one values -; -(defadt ::zero zero) -(defadt ::one one) - -(derive ::zero root-type) -(derive ::one root-type) - -; -; Addition -; -; The minimal implementation is for binary my-type. It is possible -; in principle to implement [::unary my-type] as well, though this -; doesn't make any sense. -; -(defmulti + - "Return the sum of all arguments. The minimal implementation for type - ::my-type is the binary form with dispatch value [::my-type ::my-type]." - {:arglists '([x] [x y] [x y & more])} - nary-dispatch) - -(defmethod + nulary-type - [] - zero) - -(defmethod + root-type - [x] x) - -(defmethod + [root-type ::zero] - [x y] x) - -(defmethod + [::zero root-type] - [x y] y) - -(defmethod + nary-type - [x y & more] - (if more - (recur (+ x y) (first more) (next more)) - (+ x y))) - -; -; Subtraction -; -; The minimal implementation is for unary my-type. A default binary -; implementation is provided as (+ x (- y)), but it is possible to -; implement unary my-type explicitly for efficiency reasons. -; -(defmulti - - "Return the difference of the first argument and the sum of all other - arguments. The minimal implementation for type ::my-type is the binary - form with dispatch value [::my-type ::my-type]." - {:arglists '([x] [x y] [x y & more])} - nary-dispatch) - -(defmethod - nulary-type - [] - (throw (java.lang.IllegalArgumentException. - "Wrong number of arguments passed"))) - -(defmethod - [root-type ::zero] - [x y] x) - -(defmethod - [::zero root-type] - [x y] (- y)) - -(defmethod - [root-type root-type] - [x y] (+ x (- y))) - -(defmethod - nary-type - [x y & more] - (if more - (recur (- x y) (first more) (next more)) - (- x y))) - -; -; Multiplication -; -; The minimal implementation is for binary [my-type my-type]. It is possible -; in principle to implement unary my-type as well, though this -; doesn't make any sense. -; -(defmulti * - "Return the product of all arguments. The minimal implementation for type - ::my-type is the binary form with dispatch value [::my-type ::my-type]." - {:arglists '([x] [x y] [x y & more])} - nary-dispatch) - -(defmethod * nulary-type - [] - one) - -(defmethod * root-type - [x] x) - -(defmethod * [root-type ::one] - [x y] x) - -(defmethod * [::one root-type] - [x y] y) - -(defmethod * nary-type - [x y & more] - (if more - (recur (* x y) (first more) (next more)) - (* x y))) - -; -; Division -; -; The minimal implementation is for unary my-type. A default binary -; implementation is provided as (* x (/ y)), but it is possible to -; implement binary [my-type my-type] explicitly for efficiency reasons. -; -(defmulti / - "Return the quotient of the first argument and the product of all other - arguments. The minimal implementation for type ::my-type is the binary - form with dispatch value [::my-type ::my-type]." - {:arglists '([x] [x y] [x y & more])} - nary-dispatch) - -(defmethod / nulary-type - [] - (throw (java.lang.IllegalArgumentException. - "Wrong number of arguments passed"))) - -(defmethod / [root-type ::one] - [x y] x) - -(defmethod / [::one root-type] - [x y] (/ y)) - -(defmethod / [root-type root-type] - [x y] (* x (/ y))) - -(defmethod / nary-type - [x y & more] - (if more - (recur (/ x y) (first more) (next more)) - (/ x y))) - -; -; Macros to permit access to the / multimethod via namespace qualification -; -(defmacro defmethod* - "Define a method implementation for the multimethod name in namespace ns. - Required for implementing the division function from another namespace." - [ns name & args] - (let [qsym (symbol (str ns) (str name))] - `(defmethod ~qsym ~@args))) - -(defmacro qsym - "Create the qualified symbol corresponding to sym in namespace ns. - Required to access the division function from another namespace, - e.g. as (qsym clojure.contrib.generic.arithmetic /)." - [ns sym] - (symbol (str ns) (str sym))) - -; -; Minimal implementations for java.lang.Number -; -(defmethod + [java.lang.Number java.lang.Number] - [x y] (clojure.core/+ x y)) - -(defmethod - java.lang.Number - [x] (clojure.core/- x)) - -(defmethod * [java.lang.Number java.lang.Number] - [x y] (clojure.core/* x y)) - -(defmethod / java.lang.Number - [x] (clojure.core// x)) - diff --git a/src/clojure/contrib/generic/collection.clj b/src/clojure/contrib/generic/collection.clj deleted file mode 100644 index c708050b..00000000 --- a/src/clojure/contrib/generic/collection.clj +++ /dev/null @@ -1,116 +0,0 @@ -;; Generic interfaces for collection-related functions - -;; by Konrad Hinsen -;; last updated May 5, 2009 - -;; Copyright (c) Konrad Hinsen, 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. - -(ns - #^{:author "Konrad Hinsen" - :doc "Generic arithmetic interface - This library defines generic versions of common - collection-related functions as multimethods that can be - defined for any type."} - clojure.contrib.generic.collection - (:refer-clojure :exclude [assoc conj dissoc empty get into seq])) - -; -; assoc -; -(defmulti assoc - "Returns a new collection in which the values corresponding to the - given keys are updated by the given values. Each type of collection - can have specific restrictions on the possible keys." - {:arglists '([coll & key-val-pairs])} - (fn [coll & items] (type coll))) - -(defmethod assoc :default - [map & key-val-pairs] - (apply clojure.core/assoc map key-val-pairs)) - -; assoc-in - -; -; conj -; -(defmulti conj - "Returns a new collection resulting from adding all xs to coll." - {:arglists '([coll & xs])} - (fn [coll & xs] (type coll))) - -(defmethod conj :default - [coll & xs] - (apply clojure.core/conj coll xs)) - -; -; diassoc -; -(defmulti dissoc - "Returns a new collection in which the entries corresponding to the - given keys are removed. Each type of collection can have specific - restrictions on the possible keys." - {:arglists '([coll & keys])} - (fn [coll & keys] (type coll))) - -(defmethod dissoc :default - [map & keys] - (apply clojure.core/dissoc map keys)) - -; -; empty -; -(defmulti empty - "Returns an empty collection of the same kind as the argument" - {:arglists '([coll])} - type) - -(defmethod empty :default - [coll] - (clojure.core/empty coll)) - -; -; get -; -(defmulti get - "Returns the element of coll referred to by key. Each type of collection - can have specific restrictions on the possible keys." - {:arglists '([coll key] [coll key not-found])} - (fn [coll & args] (type coll))) - -(defmethod get :default - ([coll key] - (clojure.core/get coll key)) - ([coll key not-found] - (clojure.core/get coll key not-found))) - -; -; into -; -(defmulti into - "Returns a new coll consisting of to-coll with all of the items of - from-coll conjoined." - {:arglists '([to from])} - (fn [to from] (type to))) - -(declare seq) -(defmethod into :default - [to from] - (reduce conj to (seq from))) - -; -; seq -; -(defmulti seq - "Returns a seq on the object s." - {:arglists '([s])} - type) - -(defmethod seq :default - [s] - (clojure.core/seq s)) diff --git a/src/clojure/contrib/generic/comparison.clj b/src/clojure/contrib/generic/comparison.clj deleted file mode 100644 index 7e2b81fd..00000000 --- a/src/clojure/contrib/generic/comparison.clj +++ /dev/null @@ -1,177 +0,0 @@ -;; Generic interfaces for comparison operations - -;; by Konrad Hinsen -;; last updated May 5, 2009 - -;; Copyright (c) Konrad Hinsen, 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. - -(ns - #^{:author "Konrad Hinsen" - :doc "Generic comparison interface - This library defines generic versions of = < > <= >= zero? - as multimethods that can be defined for any type. Of the - greater/less-than relations, types must minimally implement >."} - clojure.contrib.generic.comparison - (:refer-clojure :exclude [= < > <= >= zero?]) - (:use [clojure.contrib.generic - :only (root-type nulary-type nary-type nary-dispatch)])) - -; -; zero? -; -(defmulti zero? - "Return true of x is zero." - {:arglists '([x])} - type) - -; -; Equality -; -(defmulti = - "Return true if all arguments are equal. The minimal implementation for type - ::my-type is the binary form with dispatch value [::my-type ::my-type]." - {:arglists '([x] [x y] [x y & more])} - nary-dispatch) - -(defmethod = root-type - [x] true) - -(defmethod = nary-type - [x y & more] - (if (= x y) - (if (next more) - (recur y (first more) (next more)) - (= y (first more))) - false)) - -; -; Greater-than -; -(defmulti > - "Return true if each argument is larger than the following ones. - The minimal implementation for type ::my-type is the binary form - with dispatch value [::my-type ::my-type]." - {:arglists '([x] [x y] [x y & more])} - nary-dispatch) - -(defmethod > root-type - [x] true) - -(defmethod > nary-type - [x y & more] - (if (> x y) - (if (next more) - (recur y (first more) (next more)) - (> y (first more))) - false)) - -; -; Less-than defaults to greater-than with arguments inversed -; -(defmulti < - "Return true if each argument is smaller than the following ones. - The minimal implementation for type ::my-type is the binary form - with dispatch value [::my-type ::my-type]. A default implementation - is provided in terms of >." - {:arglists '([x] [x y] [x y & more])} - nary-dispatch) - -(defmethod < root-type - [x] true) - -(defmethod < [root-type root-type] - [x y] - (> y x)) - -(defmethod < nary-type - [x y & more] - (if (< x y) - (if (next more) - (recur y (first more) (next more)) - (< y (first more))) - false)) - -; -; Greater-or-equal defaults to (complement <) -; -(defmulti >= - "Return true if each argument is larger than or equal to the following - ones. The minimal implementation for type ::my-type is the binary form - with dispatch value [::my-type ::my-type]. A default implementation - is provided in terms of <." - {:arglists '([x] [x y] [x y & more])} - nary-dispatch) - -(defmethod >= root-type - [x] true) - -(defmethod >= [root-type root-type] - [x y] - (not (< x y))) - -(defmethod >= nary-type - [x y & more] - (if (>= x y) - (if (next more) - (recur y (first more) (next more)) - (>= y (first more))) - false)) - -; -; Less-than defaults to (complement >) -; -(defmulti <= - "Return true if each arguments is smaller than or equal to the following - ones. The minimal implementation for type ::my-type is the binary form - with dispatch value [::my-type ::my-type]. A default implementation - is provided in terms of >." - {:arglists '([x] [x y] [x y & more])} - nary-dispatch) - -(defmethod <= root-type - [x] true) - -(defmethod >= [root-type root-type] - [x y] - (not (> x y))) - -(defmethod <= nary-type - [x y & more] - (if (<= x y) - (if (next more) - (recur y (first more) (next more)) - (<= y (first more))) - false)) - -; -; Implementations for Clojure's built-in types -; -(defmethod zero? java.lang.Number - [x] - (clojure.core/zero? x)) - -(defmethod = [Object Object] - [x y] - (clojure.core/= x y)) - -(defmethod > [Object Object] - [x y] - (clojure.core/> x y)) - -(defmethod < [Object Object] - [x y] - (clojure.core/< x y)) - -(defmethod >= [Object Object] - [x y] - (clojure.core/>= x y)) - -(defmethod <= [Object Object] - [x y] - (clojure.core/<= x y)) diff --git a/src/clojure/contrib/generic/functor.clj b/src/clojure/contrib/generic/functor.clj deleted file mode 100644 index 9faf4603..00000000 --- a/src/clojure/contrib/generic/functor.clj +++ /dev/null @@ -1,40 +0,0 @@ -;; Generic interface for functors - -;; by Konrad Hinsen -;; last updated May 3, 2009 - -;; Copyright (c) Konrad Hinsen, 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. - -(ns - #^{:author "Konrad Hinsen" - :doc "Generic functor interface (fmap)"} - clojure.contrib.generic.functor) - - -(defmulti fmap - "Applies function f to each item in the data structure s and returns - a structure of the same kind." - {:arglists '([f s])} - (fn [f s] (type s))) - -(defmethod fmap clojure.lang.IPersistentList - [f v] - (into (empty v) (map f v))) - -(defmethod fmap clojure.lang.IPersistentVector - [f v] - (into (empty v) (map f v))) - -(defmethod fmap clojure.lang.IPersistentMap - [f m] - (into (empty m) (for [[k v] m] [k (f v)]))) - -(defmethod fmap clojure.lang.IPersistentSet - [f s] - (into (empty s) (map f s))) diff --git a/src/clojure/contrib/generic/math_functions.clj b/src/clojure/contrib/generic/math_functions.clj deleted file mode 100644 index a0fb3609..00000000 --- a/src/clojure/contrib/generic/math_functions.clj +++ /dev/null @@ -1,114 +0,0 @@ -;; Generic interfaces for mathematical functions - -;; by Konrad Hinsen -;; last updated May 5, 2009 - -;; Copyright (c) Konrad Hinsen, 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. - -(ns - #^{:author "Konrad Hinsen" - :doc "Generic math function interface - This library defines generic versions of common mathematical - functions such as sqrt or sin as multimethods that can be - defined for any type."} - clojure.contrib.generic.math-functions - (:use [clojure.contrib.def :only (defmacro-)]) - (:require [clojure.contrib.generic.arithmetic :as ga] - [clojure.contrib.generic.comparison :as gc])) - -(defmacro- defmathfn-1 - [name] - (let [java-symbol (symbol "java.lang.Math" (str name))] - `(do - (defmulti ~name - ~(str "Return the " name " of x.") - {:arglists '([~'x])} - type) - (defmethod ~name java.lang.Number - [~'x] - (~java-symbol ~'x))))) - -(defn- two-types [x y] [(type x) (type y)]) - -(defmacro- defmathfn-2 - [name] - (let [java-symbol (symbol "java.lang.Math" (str name))] - `(do - (defmulti ~name - ~(str "Return the " name " of x and y.") - {:arglists '([~'x ~'y])} - two-types) - (defmethod ~name [java.lang.Number java.lang.Number] - [~'x ~'y] - (~java-symbol ~'x ~'y))))) - -; List of math functions taken from -; http://java.sun.com/j2se/1.4.2/docs/api/java/lang/Math.html -(defmathfn-1 abs) -(defmathfn-1 acos) -(defmathfn-1 asin) -(defmathfn-1 atan) -(defmathfn-2 atan2) -(defmathfn-1 ceil) -(defmathfn-1 cos) -(defmathfn-1 exp) -(defmathfn-1 floor) -(defmathfn-1 log) -(defmathfn-2 pow) -(defmathfn-1 rint) -(defmathfn-1 round) -(defmathfn-1 sin) -(defmathfn-1 sqrt) -(defmathfn-1 tan) - -; -; Sign -; -(defmulti sgn - "Return the sign of x (-1, 0, or 1)." - {:arglists '([x])} - type) - -(defmethod sgn :default - [x] - (cond (gc/zero? x) 0 - (gc/> x 0) 1 - :else -1)) - -; -; Conjugation -; -(defmulti conjugate - "Return the conjugate of x." - {:arglists '([x])} - type) - -(defmethod conjugate :default - [x] x) - -; -; Square -; -(defmulti sqr - "Return the square of x." - {:arglists '([x])} - type) - -(defmethod sqr :default - [x] - (ga/* x x)) - -; -; Approximate equality for use with floating point types -; -(defn approx= - "Return true if the absolute value of the difference between x and y - is less than eps." - [x y eps] - (gc/< (abs (ga/- x y)) eps)) diff --git a/src/clojure/contrib/graph.clj b/src/clojure/contrib/graph.clj deleted file mode 100644 index 0be6420c..00000000 --- a/src/clojure/contrib/graph.clj +++ /dev/null @@ -1,228 +0,0 @@ -;; Copyright (c) Jeffrey Straszheim. 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. -;; -;; graph -;; -;; Basic Graph Theory Algorithms -;; -;; straszheimjeffrey (gmail) -;; Created 23 June 2009 - - -(ns - #^{:author "Jeffrey Straszheim", - :doc "Basic graph theory algorithms"} - clojure.contrib.graph - (use [clojure.set :only (union)])) - - -(defstruct directed-graph - :nodes ; The nodes of the graph, a collection - :neighbors) ; A function that, given a node returns a collection - ; neighbor nodes. - -(defn get-neighbors - "Get the neighbors of a node." - [g n] - ((:neighbors g) n)) - - -;; Graph Modification - -(defn reverse-graph - "Given a directed graph, return another directed graph with the - order of the edges reversed." - [g] - (let [op (fn [rna idx] - (let [ns (get-neighbors g idx) - am (fn [m val] - (assoc m val (conj (get m val #{}) idx)))] - (reduce am rna ns))) - rn (reduce op {} (:nodes g))] - (struct directed-graph (:nodes g) rn))) - -(defn add-loops - "For each node n, add the edge n->n if not already present." - [g] - (struct directed-graph - (:nodes g) - (into {} (map (fn [n] - [n (conj (set (get-neighbors g n)) n)]) (:nodes g))))) - -(defn remove-loops - "For each node n, remove any edges n->n." - [g] - (struct directed-graph - (:nodes g) - (into {} (map (fn [n] - [n (disj (set (get-neighbors g n)) n)]) (:nodes g))))) - - -;; Graph Walk - -(defn lazy-walk - "Return a lazy sequence of the nodes of a graph starting a node n. Optionally, - provide a set of visited notes (v) and a collection of nodes to - visit (ns)." - ([g n] - (lazy-walk g [n] #{})) - ([g ns v] - (lazy-seq (let [s (seq (drop-while v ns)) - n (first s) - ns (rest s)] - (when s - (cons n (lazy-walk g (concat (get-neighbors g n) ns) (conj v n)))))))) - -(defn transitive-closure - "Returns the transitive closure of a graph. The neighbors are lazily computed. - - Note: some version of this algorithm return all edges a->a - regardless of whether such loops exist in the original graph. This - version does not. Loops will be included only if produced by - cycles in the graph. If you have code that depends on such - behavior, call (-> g transitive-closure add-loops)" - [g] - (let [nns (fn [n] - [n (delay (lazy-walk g (get-neighbors g n) #{}))]) - nbs (into {} (map nns (:nodes g)))] - (struct directed-graph - (:nodes g) - (fn [n] (force (nbs n)))))) - - -;; Strongly Connected Components - -(defn- post-ordered-visit - "Starting at node n, perform a post-ordered walk." - [g n [visited acc :as state]] - (if (visited n) - state - (let [[v2 acc2] (reduce (fn [st nd] (post-ordered-visit g nd st)) - [(conj visited n) acc] - (get-neighbors g n))] - [v2 (conj acc2 n)]))) - -(defn post-ordered-nodes - "Return a sequence of indexes of a post-ordered walk of the graph." - [g] - (fnext (reduce #(post-ordered-visit g %2 %1) - [#{} []] - (:nodes g)))) - -(defn scc - "Returns, as a sequence of sets, the strongly connected components - of g." - [g] - (let [po (reverse (post-ordered-nodes g)) - rev (reverse-graph g) - step (fn [stack visited acc] - (if (empty? stack) - acc - (let [[nv comp] (post-ordered-visit rev - (first stack) - [visited #{}]) - ns (remove nv stack)] - (recur ns nv (conj acc comp)))))] - (step po #{} []))) - -(defn component-graph - "Given a graph, perhaps with cycles, return a reduced graph that is acyclic. - Each node in the new graph will be a set of nodes from the old. - These sets are the strongly connected components. Each edge will - be the union of the corresponding edges of the prior graph." - ([g] - (component-graph g (scc g))) - ([g sccs] - (let [find-node-set (fn [n] - (some #(if (% n) % nil) sccs)) - find-neighbors (fn [ns] - (let [nbs1 (map (partial get-neighbors g) ns) - nbs2 (map set nbs1) - nbs3 (apply union nbs2)] - (set (map find-node-set nbs3)))) - nm (into {} (map (fn [ns] [ns (find-neighbors ns)]) sccs))] - (struct directed-graph (set sccs) nm)))) - -(defn recursive-component? - "Is the component (recieved from scc) self recursive?" - [g ns] - (or (> (count ns) 1) - (let [n (first ns)] - (some #(= % n) (get-neighbors g n))))) - -(defn self-recursive-sets - "Returns, as a sequence of sets, the components of a graph that are - self-recursive." - [g] - (filter (partial recursive-component? g) (scc g))) - - -;; Dependency Lists - -(defn fixed-point - "Repeatedly apply fun to data until (equal old-data new-data) - returns true. If max iterations occur, it will throw an - exception. Set max to nil for unlimited iterations." - [data fun max equal] - (let [step (fn step [data idx] - (when (and idx (= 0 idx)) - (throw (Exception. "Fixed point overflow"))) - (let [new-data (fun data)] - (if (equal data new-data) - new-data - (recur new-data (and idx (dec idx))))))] - (step data max))) - -(defn- fold-into-sets - [priorities] - (let [max (inc (apply max 0 (vals priorities))) - step (fn [acc [n dep]] - (assoc acc dep (conj (acc dep) n)))] - (reduce step - (vec (replicate max #{})) - priorities))) - -(defn dependency-list - "Similar to a topological sort, this returns a vector of sets. The - set of nodes at index 0 are independent. The set at index 1 depend - on index 0; those at 2 depend on 0 and 1, and so on. Those withing - a set have no mutual dependencies. Assume the input graph (which - much be acyclic) has an edge a->b when a depends on b." - [g] - (let [step (fn [d] - (let [update (fn [n] - (inc (apply max -1 (map d (get-neighbors g n)))))] - (into {} (map (fn [[k v]] [k (update k)]) d)))) - counts (fixed-point (zipmap (:nodes g) (repeat 0)) - step - (inc (count (:nodes g))) - =)] - (fold-into-sets counts))) - -(defn stratification-list - "Similar to dependency-list (see doc), except two graphs are - provided. The first is as dependency-list. The second (which may - have cycles) provides a partial-dependency relation. If node a - depends on node b (meaning an edge a->b exists) in the second - graph, node a must be equal or later in the sequence." - [g1 g2] - (assert (= (-> g1 :nodes set) (-> g2 :nodes set))) - (let [step (fn [d] - (let [update (fn [n] - (max (inc (apply max -1 - (map d (get-neighbors g1 n)))) - (apply max -1 (map d (get-neighbors g2 n)))))] - (into {} (map (fn [[k v]] [k (update k)]) d)))) - counts (fixed-point (zipmap (:nodes g1) (repeat 0)) - step - (inc (count (:nodes g1))) - =)] - (fold-into-sets counts))) - - -;; End of file diff --git a/src/clojure/contrib/greatest_least.clj b/src/clojure/contrib/greatest_least.clj deleted file mode 100644 index 79e41813..00000000 --- a/src/clojure/contrib/greatest_least.clj +++ /dev/null @@ -1,65 +0,0 @@ -(ns - #^{:author "Vincent Foley", - :doc "Various functions for finding greatest and least values in a collection"} - clojure.contrib.greatest-least) - -(defn- boundary - [cmp-fn f & args] - (when args - (reduce (fn [a b] (if (cmp-fn (compare (f b) (f a))) - b - a)) args))) - -(defn greatest-by - "Return the argument for which f yields the greatest value." - [f & args] - (apply boundary pos? f args)) - -(defn greatest - "Return the greatest argument." - [& args] - (apply greatest-by identity args)) - -(defn least-by - "Return the argument for which f yields the smallest value." - [f & args] - (apply boundary neg? f args)) - -(defn least - "Return the smallest element." - [& args] - (apply least-by identity args)) - - -(defn- boundary-all - [cmp-fn f & args] - (when args - (reduce (fn [a b] - (if (nil? a) - (cons b nil) - (let [x (compare (f b) (f (first a)))] - (cond (zero? x) (cons b a) - (cmp-fn x) (cons b nil) - :else a)))) - nil - args))) - -(defn all-greatest-by - "Return all the elements for which f yields the greatest value." - [f & args] - (apply boundary-all pos? f args)) - -(defn all-greatest - "Returns all the greatest elements." - [& args] - (apply all-greatest-by identity args)) - -(defn all-least-by - "Return all the elements for which f yields the least value." - [f & args] - (apply boundary-all neg? f args)) - -(defn all-least - "Returns all the least elements." - [& args] - (apply all-least-by identity args)) diff --git a/src/clojure/contrib/http/agent.clj b/src/clojure/contrib/http/agent.clj deleted file mode 100644 index 6a3e082f..00000000 --- a/src/clojure/contrib/http/agent.clj +++ /dev/null @@ -1,379 +0,0 @@ -;;; http/agent.clj: agent-based asynchronous HTTP client - -;; by Stuart Sierra, http://stuartsierra.com/ -;; August 17, 2009 - -;; Copyright (c) Stuart Sierra, 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. - - -(ns #^{:doc "Agent-based asynchronous HTTP client. - - This is a HTTP client library based on Java's HttpURLConnection - class and Clojure's Agent system. It allows you to make multiple - HTTP requests in parallel. - - Start an HTTP request with the 'http-agent' function, which - immediately returns a Clojure Agent. You will never deref this - agent; that is handled by the accessor functions. The agent will - execute the HTTP request on a separate thread. - - If you pass a :handler function to http-agent, that function will be - called as soon as the HTTP response body is ready. The handler - function is called with one argument, the HTTP agent itself. The - handler can read the response body by calling the 'stream' function - on the agent. - - The value returned by the handler function becomes part of the state - of the agent, and you can retrieve it with the 'result' function. - If you call 'result' before the HTTP request has finished, it will - block until the handler function returns. - - If you don't provide a handler function, the default handler will - buffer the entire response body in memory, which you can retrieve - with the 'bytes', 'string', or 'stream' functions. Like 'result', - these functions will block until the HTTP request is completed. - - If you want to check if an HTTP request is finished without - blocking, use the 'done?' function. - - A single GET request could be as simple as: - - (string (http-agent \"http://www.stuartsierra.com/\")) - - A simple POST might look like: - - (http-agent \"http...\" :method \"POST\" :body \"foo=1\") - - And you could write the response directly to a file like this: - - (require '[clojure.contrib.duck-streams :as d]) - - (http-agent \"http...\" - :handler (fn [agnt] - (with-open [w (d/writer \"/tmp/out\")] - (d/copy (stream agnt) w)))) -" - :author "Stuart Sierra" - } - - clojure.contrib.http.agent - (:refer-clojure :exclude [bytes]) - (:require [clojure.contrib.http.connection :as c] - [clojure.contrib.duck-streams :as duck]) - (:import (java.io InputStream ByteArrayOutputStream - ByteArrayInputStream) - (java.net HttpURLConnection))) - - -;;; PRIVATE - -(declare result stream) - -(defn- setup-http-connection - "Sets the instance method, redirect behavior, and request headers of - the HttpURLConnection." - [#^HttpURLConnection conn options] - (.setRequestMethod conn (:method options)) - (.setInstanceFollowRedirects conn (:follow-redirects options)) - (doseq [[name value] (:headers options)] - (.setRequestProperty conn name value))) - -(defn- start-request - "Agent action that starts sending the HTTP request." - [state options] - (let [conn (::connection state)] - (setup-http-connection conn options) - (c/start-http-connection conn (:body options)) - (assoc state ::state ::started))) - -(defn- connection-success? [#^HttpURLConnection conn] - "Returns true if the HttpURLConnection response code is in the 2xx - range." - (= 2 (unchecked-divide (.getResponseCode conn) 100))) - -(defn- open-response - "Agent action that opens the response body stream on the HTTP - request; this will block until the response stream is available." ; - [state options] - (let [#^HttpURLConnection conn (::connection state)] - (assoc state - ::response-stream (if (connection-success? conn) - (.getInputStream conn) - (.getErrorStream conn)) - ::state ::receiving))) - -(defn- handle-response - "Agent action that calls the provided handler function, with no - arguments, and sets the ::result key of the agent to the handler's - return value." - [state handler options] - (let [conn (::connection state)] - (assoc state - ::result (handler) - ::state ::finished))) - -(defn- disconnect - "Agent action that closes the response body stream and disconnects - the HttpURLConnection." - [state options] - (when (::response-stream state) - (.close #^InputStream (::response-stream state))) - (.disconnect #^HttpURLConnection (::connection state)) - (assoc state - ::response-stream nil - ::state ::disconnected)) - -(defn- status-in-range? - "Returns true if the response status of the HTTP agent begins with - digit, an Integer." - [digit http-agnt] - (= digit (unchecked-divide (.getResponseCode - #^HttpURLConnection (::connection @http-agnt)) - 100))) - -(defn- #^ByteArrayOutputStream get-byte-buffer [http-agnt] - (let [buffer (result http-agnt)] - (if (instance? ByteArrayOutputStream buffer) - buffer - (throw (Exception. "Handler result was not a ByteArrayOutputStream"))))) - - -(defn buffer-bytes - "The default HTTP agent result handler; it collects the response - body in a java.io.ByteArrayOutputStream, which can later be - retrieved with the 'stream', 'string', and 'bytes' functions." - [http-agnt] - (let [output (ByteArrayOutputStream.)] - (duck/copy (or (stream http-agnt) "") output) - output)) - - -;;; CONSTRUCTOR - -(def *http-agent-defaults* - {:method "GET" - :headers {} - :body nil - :connect-timeout 0 - :read-timeout 0 - :follow-redirects true - :handler buffer-bytes}) - -(defn http-agent - "Creates (and immediately returns) an Agent representing an HTTP - request running in a new thread. - - options are key/value pairs: - - :method string - - The HTTP method name. Default is \"GET\". - - :headers h - - HTTP headers, as a Map or a sequence of pairs like - ([key1,value1], [key2,value2]) Default is nil. - - :body b - - HTTP request entity body, one of nil, String, byte[], InputStream, - Reader, or File. Default is nil. - - :connect-timeout int - - Timeout value, in milliseconds, when opening a connection to the - URL. Default is zero, meaning no timeout. - - :read-timeout int - - Timeout value, in milliseconds, when reading data from the - connection. Default is zero, meaning no timeout. - - :follow-redirects boolean - - If true, HTTP 3xx redirects will be followed automatically. Default - is true. - - :handler f - - Function to be called when the HTTP response body is ready. If you - do not provide a handler function, the default is to buffer the - entire response body in memory. - - The handler function will be called with the HTTP agent as its - argument, and can use the 'stream' function to read the response - body. The return value of this function will be stored in the state - of the agent and can be retrieved with the 'result' function. Any - exceptions thrown by this function will be added to the agent's - error queue (see agent-errors). The default function collects the - response stream in a memory buffer. - " - ([uri & options] - (let [opts (merge *http-agent-defaults* (apply array-map options))] - (let [a (agent {::connection (c/http-connection uri) - ::state ::created - ::uri uri - ::options opts})] - (send-off a start-request opts) - (send-off a open-response opts) - (send-off a handle-response (partial (:handler opts) a) opts) - (send-off a disconnect opts))))) - - -;;; RESPONSE BODY ACCESSORS - -(defn result - "Returns the value returned by the :handler function of the HTTP - agent; blocks until the HTTP request is completed. The default - handler function returns a ByteArrayOutputStream." - [http-agnt] - (await http-agnt) - (::result @http-agnt)) - -(defn stream - "Returns an InputStream of the HTTP response body. When called by - the handler function passed to http-agent, this is the raw - HttpURLConnection stream. - - If the default handler function was used, this function returns a - ByteArrayInputStream on the buffered response body." - [http-agnt] - (let [a @http-agnt] - (if (= (::state a) ::receiving) - (::response-stream a) - (ByteArrayInputStream. - (.toByteArray (get-byte-buffer http-agnt)))))) - -(defn bytes - "Returns a Java byte array of the content returned by the server; - nil if the content is not yet available." - [http-agnt] - (.toByteArray (get-byte-buffer http-agnt))) - -(defn string - "Returns the HTTP response body as a string, using the given - encoding. - - If no encoding is given, uses the encoding specified in the server - headers, or clojure.contrib.duck-streams/*default-encoding* if it is - not specified." - ([http-agnt] - (await http-agnt) ;; have to wait for Content-Encoding - (string http-agnt (or (.getContentEncoding - #^HttpURLConnection (::connection @http-agnt)) - duck/*default-encoding*))) - ([http-agnt #^String encoding] - (.toString (get-byte-buffer http-agnt) encoding))) - - -;;; REQUEST ACCESSORS - -(defn request-uri - "Returns the URI/URL requested by this HTTP agent, as a String." - [http-agnt] - (::uri @http-agnt)) - -(defn request-headers - "Returns the request headers specified for this HTTP agent." - [http-agnt] - (:headers (::options @http-agnt))) - -(defn method - "Returns the HTTP method name used by this HTTP agent, as a String." - [http-agnt] - (:method (::options @http-agnt))) - -(defn request-body - "Returns the HTTP request body given to this HTTP agent. - - Note: if the request body was an InputStream or a Reader, it will no - longer be usable." - [http-agnt] - (:body (::options @http-agnt))) - - -;;; RESPONSE ACCESSORS - -(defn done? - "Returns true if the HTTP request/response has completed." - [http-agnt] - (if (#{::finished ::disconnected} (::state @http-agnt)) - true false)) - -(defn status - "Returns the HTTP response status code (e.g. 200, 404) for this - request, as an Integer, or nil if the status has not yet been - received." - [http-agnt] - (when (done? http-agnt) - (.getResponseCode #^HttpURLConnection (::connection @http-agnt)))) - -(defn message - "Returns the HTTP response message (e.g. 'Not Found'), for this - request, or nil if the response has not yet been received." - [http-agnt] - (when (done? http-agnt) - (.getResponseMessage #^HttpURLConnection (::connection @http-agnt)))) - -(defn headers - "Returns a map of HTTP response headers. Header names are converted - to keywords in all lower-case Header values are strings. If a - header appears more than once, only the last value is returned." - [http-agnt] - (reduce (fn [m [#^String k v]] - (assoc m (when k (keyword (.toLowerCase k))) (last v))) - {} (.getHeaderFields - #^HttpURLConnection (::connection @http-agnt)))) - -(defn headers-seq - "Returns the HTTP response headers in order as a sequence of - [String,String] pairs. The first 'header' name may be null for the - HTTP status line." - [http-agnt] - (let [#^HttpURLConnection conn (::connection @http-agnt) - f (fn thisfn [#^Integer i] - ;; Get value first because first key may be nil. - (when-let [value (.getHeaderField conn i)] - (cons [(.getHeaderFieldKey conn i) value] - (thisfn (inc i)))))] - (lazy-seq (f 0)))) - - -;;; RESPONSE STATUS CODE ACCESSORS - -(defn success? - "Returns true if the HTTP response code was in the 200-299 range." - [http-agnt] - (status-in-range? 2 http-agnt)) - -(defn redirect? - "Returns true if the HTTP response code was in the 300-399 range. - - Note: if the :follow-redirects option was true (the default), - redirects will be followed automatically and a the agent will never - return a 3xx response code." - [http-agnt] - (status-in-range? 3 http-agnt)) - -(defn client-error? - "Returns true if the HTTP response code was in the 400-499 range." - [http-agnt] - (status-in-range? 4 http-agnt)) - -(defn server-error? - "Returns true if the HTTP response code was in the 500-599 range." - [http-agnt] - (status-in-range? 5 http-agnt)) - -(defn error? - "Returns true if the HTTP response code was in the 400-499 range OR - the 500-599 range." - [http-agnt] - (or (client-error? http-agnt) - (server-error? http-agnt))) diff --git a/src/clojure/contrib/http/connection.clj b/src/clojure/contrib/http/connection.clj deleted file mode 100644 index 4eda0fa6..00000000 --- a/src/clojure/contrib/http/connection.clj +++ /dev/null @@ -1,59 +0,0 @@ -;;; http/connection.clj: low-level HTTP client API around HttpURLConnection - -;; by Stuart Sierra, http://stuartsierra.com/ -;; June 8, 2009 - -;; Copyright (c) Stuart Sierra, 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. - -(ns #^{:doc "Low-level HTTP client API around HttpURLConnection"} - clojure.contrib.http.connection - (:require [clojure.contrib.duck-streams :as duck] - [clojure.contrib.java-utils :as j]) - (:import (java.net URI URL HttpURLConnection) - (java.io File InputStream Reader))) - -(defn http-connection - "Opens an HttpURLConnection at the URL, handled by as-url." - [url] - (.openConnection (j/as-url url))) - -(defmulti - #^{:doc "Transmits a request entity body."} - send-request-entity (fn [conn entity] (type entity))) - -(defmethod send-request-entity duck/*byte-array-type* [#^HttpURLConnection conn entity] - (.setFixedLengthStreamingMode conn (count entity)) - (.connect conn) - (duck/copy entity (.getOutputStream conn))) - -(defmethod send-request-entity String [conn #^String entity] - (send-request-entity conn (.getBytes entity duck/*default-encoding*))) - -(defmethod send-request-entity File [#^HttpURLConnection conn #^File entity] - (.setFixedLengthStreamingMode conn (.length entity)) - (.connect conn) - (duck/copy entity (.getOutputStream conn))) - -(defmethod send-request-entity InputStream [#^HttpURLConnection conn entity] - (.setChunkedStreamingMode conn -1) - (.connect conn) - (duck/copy entity (.getOutputStream conn))) - -(defmethod send-request-entity Reader [#^HttpURLConnection conn entity] - (.setChunkedStreamingMode conn -1) - (.connect conn) - (duck/copy entity (.getOutputStream conn))) - -(defn start-http-connection - ([#^HttpURLConnection conn] (.connect conn)) - ([#^HttpURLConnection conn request-entity-body] - (if request-entity-body - (do (.setDoOutput conn true) - (send-request-entity conn request-entity-body)) - (.connect conn)))) diff --git a/src/clojure/contrib/import_static.clj b/src/clojure/contrib/import_static.clj deleted file mode 100644 index 94d827a5..00000000 --- a/src/clojure/contrib/import_static.clj +++ /dev/null @@ -1,63 +0,0 @@ -;;; import_static.clj -- import static Java methods/fields into Clojure - -;; by Stuart Sierra, http://stuartsierra.com/ -;; June 1, 2008 - -;; Copyright (c) Stuart Sierra, 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. - - - -(ns - #^{:author "Stuart Sierra", - :doc "Import static Java methods/fields into Clojure"} - clojure.contrib.import-static - (:use clojure.set)) - -(defmacro import-static - "Imports the named static fields and/or static methods of the class - as (private) symbols in the current namespace. - - Example: - user=> (import-static java.lang.Math PI sqrt) - nil - user=> PI - 3.141592653589793 - user=> (sqrt 16) - 4.0 - - Note: The class name must be fully qualified, even if it has already - been imported. Static methods are defined as MACROS, not - first-class fns." - [class & fields-and-methods] - (let [only (set (map str fields-and-methods)) - the-class (. Class forName (str class)) - static? (fn [x] - (. java.lang.reflect.Modifier - (isStatic (. x (getModifiers))))) - statics (fn [array] - (set (map (memfn getName) - (filter static? array)))) - all-fields (statics (. the-class (getFields))) - all-methods (statics (. the-class (getMethods))) - fields-to-do (intersection all-fields only) - methods-to-do (intersection all-methods only) - make-sym (fn [string] - (with-meta (symbol string) {:private true})) - import-field (fn [name] - (list 'def (make-sym name) - (list '. class (symbol name)))) - import-method (fn [name] - (list 'defmacro (make-sym name) - '[& args] - (list 'list ''. (list 'quote class) - (list 'apply 'list - (list 'quote (symbol name)) - 'args))))] - `(do ~@(map import-field fields-to-do) - ~@(map import-method methods-to-do)))) diff --git a/src/clojure/contrib/jar.clj b/src/clojure/contrib/jar.clj deleted file mode 100644 index de979bba..00000000 --- a/src/clojure/contrib/jar.clj +++ /dev/null @@ -1,35 +0,0 @@ -;;; jar.clj: utilities for working with Java JAR files - -;; by Stuart Sierra, http://stuartsierra.com/ -;; April 19, 2009 - -;; Copyright (c) Stuart Sierra, 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. - - -(ns - #^{:author "Stuart Sierra", - :doc "Utilities for working with Java JAR files"} - clojure.contrib.jar - (:import (java.io File) - (java.util.jar JarFile))) - -(defn jar-file? - "Returns true if file is a normal file with a .jar or .JAR extension." - [#^File file] - (and (.isFile file) - (or (.endsWith (.getName file) ".jar") - (.endsWith (.getName file) ".JAR")))) - -(defn filenames-in-jar - "Returns a sequence of Strings naming the non-directory entries in - the JAR file." - [#^JarFile jar-file] - (map #(.getName %) - (filter #(not (.isDirectory %)) - (enumeration-seq (.entries jar-file))))) diff --git a/src/clojure/contrib/java_utils.clj b/src/clojure/contrib/java_utils.clj deleted file mode 100644 index e8d93782..00000000 --- a/src/clojure/contrib/java_utils.clj +++ /dev/null @@ -1,223 +0,0 @@ -; Copyright (c) Stuart Halloway & Contributors, April 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. - -; Design goals: -; -; (1) Ease-of-use. These APIs should be convenient. Performance is secondary. -; -; (2) Duck typing. I hate having to think about the difference between -; a string that names a file, and a File. Ditto for a ton of other -; wrapper classes in the Java world (URL, InternetAddress). With these -; APIs you should be able to think about domain equivalence, not type -; equivalence. -; -; (3) No bossiness. I am not marking any of these functions as private; -; the docstrings will tell you the intended usage but do what works for you. -; -; Feedback welcome! -; -; If something in this module violates the principle of least surprise, please -; let me (Stu) and the Clojure community know via the mailing list. -; -; Contributors: -; -; Stuart Halloway -; Stephen C. Gilardi -; Shawn Hoover -; Perry Trolard -; Stuart Sierra - -(ns - #^{:author "Stuart Halloway, Stephen C. Gilardi, Shawn Hoover, Perry Trolard, Stuart Sierra", - :doc "A set of utilties for dealing with Java stuff like files and properties. - - Design goals: - - (1) Ease-of-use. These APIs should be convenient. Performance is secondary. - - (2) Duck typing. I hate having to think about the difference between - a string that names a file, and a File. Ditto for a ton of other - wrapper classes in the Java world (URL, InternetAddress). With these - APIs you should be able to think about domain equivalence, not type - equivalence. - - (3) No bossiness. I am not marking any of these functions as private - the docstrings will tell you the intended usage but do what works for you. - - Feedback welcome! - - If something in this module violates the principle of least surprise, please - let me (Stu) and the Clojure community know via the mailing list. -"} - clojure.contrib.java-utils - (:import [java.io File FileOutputStream] - [java.util Properties] - [java.net URI URL])) - -(defmulti relative-path-string - "Interpret a String or java.io.File as a relative path string. - Building block for clojure.contrib.java-utils/file." - class) - -(defmethod relative-path-string String [#^String s] - (relative-path-string (File. s))) - -(defmethod relative-path-string File [#^File f] - (if (.isAbsolute f) - (throw (IllegalArgumentException. (str f " is not a relative path"))) - (.getPath f))) - -(defmulti #^File as-file - "Interpret a String or a java.io.File as a File. Building block - for clojure.contrib.java-utils/file, which you should prefer - in most cases." - class) -(defmethod as-file String [#^String s] (File. s)) -(defmethod as-file File [f] f) - -(defn #^File file - "Returns a java.io.File from string or file args." - ([arg] - (as-file arg)) - ([parent child] - (File. #^File (as-file parent) #^String (relative-path-string child))) - ([parent child & more] - (reduce file (file parent child) more))) - -(defn as-str - "Like clojure.core/str, but if an argument is a keyword or symbol, - its name will be used instead of its literal representation. - - Example: - (str :foo :bar) ;;=> \":foo:bar\" - (as-str :foo :bar) ;;=> \"foobar\" - - Note that this does not apply to keywords or symbols nested within - data structures; they will be rendered as with str. - - Example: - (str {:foo :bar}) ;;=> \"{:foo :bar}\" - (as-str {:foo :bar}) ;;=> \"{:foo :bar}\" " - ([] "") - ([x] (if (instance? clojure.lang.Named x) - (name x) - (str x))) - ([x & ys] - ((fn [#^StringBuilder sb more] - (if more - (recur (. sb (append (as-str (first more)))) (next more)) - (str sb))) - (new StringBuilder #^String (as-str x)) ys))) - -(defn get-system-property - "Get a system property." - ([stringable] - (System/getProperty (as-str stringable))) - ([stringable default] - (System/getProperty (as-str stringable) default))) - -(defn set-system-properties - "Set some system properties. Nil clears a property." - [settings] - (doseq [[name val] settings] - (if val - (System/setProperty (as-str name) (as-str val)) - (System/clearProperty (as-str name))))) - -(defmacro with-system-properties - "setting => property-name value - - Sets the system properties to the supplied values, executes the body, and - sets the properties back to their original values. Values of nil are - translated to a clearing of the property." - [settings & body] - `(let [settings# ~settings - current# (reduce (fn [coll# k#] - (assoc coll# k# (get-system-property k#))) - {} - (keys settings#))] - (set-system-properties settings#) - (try - ~@body - (finally - (set-system-properties current#))))) - - -; Not there is no corresponding props->map. Just destructure! -(defn #^Properties as-properties - "Convert any seq of pairs to a java.utils.Properties instance. - Uses as-str to convert both keys and values into strings." - {:tag Properties} - [m] - (let [p (Properties.)] - (doseq [[k v] m] - (.setProperty p (as-str k) (as-str v))) - p)) - -(defn read-properties - "Read properties from file-able." - [file-able] - (with-open [f (java.io.FileInputStream. (file file-able))] - (doto (Properties.) - (.load f)))) - -(defn write-properties - "Write properties to file-able." - {:tag Properties} - ([m file-able] (write-properties m file-able nil)) - ([m file-able comments] - (with-open [#^FileOutputStream f (FileOutputStream. (file file-able))] - (doto (as-properties m) - (.store f #^String comments))))) - -(defn delete-file - "Delete file f. Raise an exception if it fails unless silently is true." - [f & [silently]] - (or (.delete (file f)) - silently - (throw (java.io.IOException. (str "Couldn't delete " f))))) - -(defn delete-file-recursively - "Delete file f. If it's a directory, recursively delete all its contents. -Raise an exception if any deletion fails unless silently is true." - [f & [silently]] - (let [f (file f)] - (if (.isDirectory f) - (doseq [child (.listFiles f)] - (delete-file-recursively child silently))) - (delete-file f silently))) - -(defmulti - #^{:doc "Coerces argument (URL, URI, or String) to a java.net.URL." - :arglists '([arg])} - as-url type) - -(defmethod as-url URL [x] x) - -(defmethod as-url URI [#^URI x] (.toURL x)) - -(defmethod as-url String [#^String x] (URL. x)) - -(defmethod as-url File [#^File x] (.toURL x)) - -(defn wall-hack-method - "Calls a private or protected method. - params is a vector of class which correspond to the arguments to the method - obj is nil for static methods, the instance object otherwise - the method name is given as a symbol or a keyword (something Named)" - [class-name method-name params obj & args] - (-> class-name (.getDeclaredMethod (name method-name) (into-array Class params)) - (doto (.setAccessible true)) - (.invoke obj (into-array Object args)))) - -(defn wall-hack-field - "Access to private or protected field." - [class-name field-name obj] - (-> class-name (.getDeclaredField (name field-name)) - (doto (.setAccessible true)) - (.get obj))) diff --git a/src/clojure/contrib/javadoc.clj b/src/clojure/contrib/javadoc.clj deleted file mode 100644 index 8a0c32e4..00000000 --- a/src/clojure/contrib/javadoc.clj +++ /dev/null @@ -1,3 +0,0 @@ -(ns clojure.contrib.javadoc) - -(throw (Exception. "clojure.contrib.javadoc/javadoc can now be found in clojure.contrib.repl-utils.")) diff --git a/src/clojure/contrib/javadoc/browse.clj b/src/clojure/contrib/javadoc/browse.clj deleted file mode 100644 index e42c5ecf..00000000 --- a/src/clojure/contrib/javadoc/browse.clj +++ /dev/null @@ -1,50 +0,0 @@ -;;; browse.clj -- start a web browser from Clojure - -; Copyright (c) Christophe Grand, December 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. - -(ns - #^{:author "Christophe Grand", - :doc "Start a web browser from Clojure"} - clojure.contrib.javadoc.browse - (:require [clojure.contrib.shell-out :as sh]) - (:import (java.net URI))) - -(defn- macosx? [] - (-> "os.name" System/getProperty .toLowerCase - (.startsWith "mac os x"))) - -(def *open-url-script* (when (macosx?) "/usr/bin/open")) - -(defn open-url-in-browser - "Opens url (a string) in the default system web browser. May not - work on all platforms. Returns url on success, nil if not - supported." - [url] - (try - (when (clojure.lang.Reflector/invokeStaticMethod "java.awt.Desktop" - "isDesktopSupported" (to-array nil)) - (-> (clojure.lang.Reflector/invokeStaticMethod "java.awt.Desktop" - "getDesktop" (to-array nil)) - (.browse (URI. url))) - url) - (catch ClassNotFoundException e - nil))) - -(defn open-url-in-swing - "Opens url (a string) in a Swing window." - [url] - ; the implementation of this function resides in another namespace to be loaded "on demand" - ; this fixes a bug on mac os x where requiring repl-utils turns the process into a GUI app - ; see http://code.google.com/p/clojure-contrib/issues/detail?id=32 - (require 'clojure.contrib.javadoc.browse-ui) - ((find-var 'clojure.contrib.javadoc.browse-ui/open-url-in-swing) url)) - -(defn browse-url [url] - (or (open-url-in-browser url) (when *open-url-script* (sh/sh *open-url-script* (str url)) true) (open-url-in-swing url))) diff --git a/src/clojure/contrib/javadoc/browse_ui.clj b/src/clojure/contrib/javadoc/browse_ui.clj deleted file mode 100644 index c76d39dd..00000000 --- a/src/clojure/contrib/javadoc/browse_ui.clj +++ /dev/null @@ -1,30 +0,0 @@ -;;; browse_ui.clj -- starts a swing web browser :-( - -; Copyright (c) Christophe Grand, December 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. - -(ns clojure.contrib.javadoc.browse-ui) - -(defn open-url-in-swing - "Opens url (a string) in a Swing window." - [url] - (let [htmlpane (javax.swing.JEditorPane. url)] - (.setEditable htmlpane false) - (.addHyperlinkListener htmlpane - (proxy [javax.swing.event.HyperlinkListener] [] - (hyperlinkUpdate [#^javax.swing.event.HyperlinkEvent e] - (when (= (.getEventType e) (. javax.swing.event.HyperlinkEvent$EventType ACTIVATED)) - (if (instance? javax.swing.text.html.HTMLFrameHyperlinkEvent e) - (-> htmlpane .getDocument (.processHTMLFrameHyperlinkEvent e)) - (.setPage htmlpane (.getURL e))))))) - (doto (javax.swing.JFrame.) - (.setContentPane (javax.swing.JScrollPane. htmlpane)) - (.setBounds 32 32 700 900) - (.show)))) -
\ No newline at end of file diff --git a/src/clojure/contrib/jmx.clj b/src/clojure/contrib/jmx.clj deleted file mode 100644 index dd6d7588..00000000 --- a/src/clojure/contrib/jmx.clj +++ /dev/null @@ -1,121 +0,0 @@ -;; 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. - - -(ns #^{:author "Stuart Halloway" - :doc "JMX support for Clojure - - Requires post-Clojure 1.0 git edge for clojure.test, clojure.backtrace. - This is prerelease. - This API will change. - Send reports to stu@thinkrelevance.com. - - Usage - (require '[clojure.contrib.jmx :as jmx]) - - What beans do I have? - - (jmx/mbean-names \"*:*\") - -> #<HashSet [java.lang:type=MemoryPool,name=CMS Old Gen, - java.lang:type=Memory, ...] - - What attributes does a bean have? - - (jmx/attribute-names \"java.lang:type=Memory\") - -> (:Verbose :ObjectPendingFinalizationCount - :HeapMemoryUsage :NonHeapMemoryUsage) - - What is the value of an attribute? - - (jmx/read \"java.lang:type=Memory\" :ObjectPendingFinalizationCount) - -> 0 - - Can't I just have *all* the attributes in a Clojure map? - - (jmx/mbean \"java.lang:type=Memory\") - -> {:NonHeapMemoryUsage - {:used 16674024, :max 138412032, :init 24317952, :committed 24317952}, - :HeapMemoryUsage - {:used 18619064, :max 85393408, :init 0, :committed 83230720}, - :ObjectPendingFinalizationCount 0, - :Verbose false} - - Can I find and invoke an operation? - - (jmx/operation-names \"java.lang:type=Memory\") - -> (:gc) - (jmx/invoke \"java.lang:type=Memory\" :gc) - -> nil - - What about some other process? Just run *any* of the above code - inside a with-connection: - - (jmx/with-connection {:host \"localhost\", :port 3000} - (jmx/mbean \"java.lang:type=Memory\")) - -> {:ObjectPendingFinalizationCount 0, - :HeapMemoryUsage ... etc.} - - Can I serve my own beans? Sure, just drop a Clojure ref - into an instance of clojure.contrib.jmx.Bean, and the bean - will expose read-only attributes for every key/value pair - in the ref: - - (jmx/register-mbean - (Bean. - (ref {:string-attribute \"a-string\"})) - \"my.namespace:name=Value\")"} - clojure.contrib.jmx - (:refer-clojure :exclude [read]) - (:use clojure.contrib.def - [clojure.contrib.java-utils :only [as-str]] - [clojure.stacktrace :only (root-cause)] - [clojure.walk :only [postwalk]]) - (:import [clojure.lang Associative] - java.lang.management.ManagementFactory - [javax.management Attribute DynamicMBean MBeanInfo ObjectName RuntimeMBeanException MBeanAttributeInfo] - [javax.management.remote JMXConnectorFactory JMXServiceURL])) - -(defvar *connection* (ManagementFactory/getPlatformMBeanServer) - "The connection to be used for JMX ops. Defaults to the local process.") - -(load "jmx/data") -(load "jmx/client") -(load "jmx/server") - -(defn mbean-names - "Finds all MBeans matching a name on the current *connection*." - [n] - (.queryNames *connection* (as-object-name n) nil)) - -(defn attribute-names - "All attribute names available on an MBean." - [n] - (doall (map #(-> % .getName keyword) - (.getAttributes (mbean-info n))))) - -(defn operation-names - "All operation names available on an MBean." - [n] - (doall (map #(-> % .getName keyword) (operations n)))) - -(defn invoke [n op & args] - (if ( seq args) - (.invoke *connection* (as-object-name n) (as-str op) - (into-array args) - (into-array String (op-param-types n op))) - (.invoke *connection* (as-object-name n) (as-str op) - nil nil))) - -(defn mbean - "Like clojure.core/bean, but for JMX beans. Returns a read-only map of - a JMX bean's attributes. If an attribute it not supported, value is - set to the exception thrown." - [n] - (into {} (map (fn [attr-name] [(keyword attr-name) (read-supported n attr-name)]) - (attribute-names n)))) - diff --git a/src/clojure/contrib/jmx/Bean.clj b/src/clojure/contrib/jmx/Bean.clj deleted file mode 100644 index cae67d21..00000000 --- a/src/clojure/contrib/jmx/Bean.clj +++ /dev/null @@ -1,35 +0,0 @@ -(ns clojure.contrib.jmx.Bean - (:gen-class - :implements [javax.management.DynamicMBean] - :init init - :state state - :constructors {[Object] []}) - (:require [clojure.contrib.jmx :as jmx]) - (:import [javax.management DynamicMBean MBeanInfo AttributeList])) - -(defn -init [derefable] - [[] derefable]) - -; TODO: rest of the arguments, as needed -(defn generate-mbean-info [clj-bean] - (MBeanInfo. (.. clj-bean getClass getName) ; class name - "Clojure Dynamic MBean" ; description - (jmx/map->attribute-infos @(.state clj-bean)) ; attributes - nil ; constructors - nil ; operations - nil)) ; notifications - -(defn -getMBeanInfo - [this] - (generate-mbean-info this)) - -(defn -getAttribute - [this attr] - (@(.state this) (keyword attr))) - -(defn -getAttributes - [this attrs] - (let [result (AttributeList.)] - (doseq [attr attrs] - (.add result (.getAttribute this attr))) - result))
\ No newline at end of file diff --git a/src/clojure/contrib/jmx/client.clj b/src/clojure/contrib/jmx/client.clj deleted file mode 100644 index 7af947d1..00000000 --- a/src/clojure/contrib/jmx/client.clj +++ /dev/null @@ -1,95 +0,0 @@ -;; 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) - -; TODO: needs an integration test -; TODO: why full package needed for JMXConnectorFactory? -(defmacro with-connection - "Execute body with JMX connection specified by opts (:port)." - [opts & body] - `(with-open [connector# (javax.management.remote.JMXConnectorFactory/connect - (JMXServiceURL. (jmx-url ~opts)) {})] - (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.") - -(defvar read-exceptions - [UnsupportedOperationException - InternalError - java.io.NotSerializableException - java.lang.ClassNotFoundException - javax.management.AttributeNotFoundException] - "Exceptions that might be thrown if you try to read an unsupported attribute. - by testing agains jconsole and Tomcat. This is dreadful and ad-hoc but I did not - want to swallow all exceptions.") - -(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 that some terribly-behaved mbeans use java.lang.InternalError to - indicate an unsupported operation!" - [n attr] - (try - (read n attr) - (catch Throwable t - (let [cause (root-cause t)] - (if (some #(instance? % cause) read-exceptions) - cause - (throw t)))))) - -(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 for 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/src/clojure/contrib/jmx/data.clj b/src/clojure/contrib/jmx/data.clj deleted file mode 100644 index 3a4c5275..00000000 --- a/src/clojure/contrib/jmx/data.clj +++ /dev/null @@ -1,104 +0,0 @@ -;; 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"} overrides)] - (format "service:jmx:rmi:///jndi/rmi://%s:%s/jmxrmi" (opts :host) (opts :port))))) - -(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/src/clojure/contrib/jmx/server.clj b/src/clojure/contrib/jmx/server.clj deleted file mode 100644 index c92fcf81..00000000 --- a/src/clojure/contrib/jmx/server.clj +++ /dev/null @@ -1,18 +0,0 @@ -;; 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/src/clojure/contrib/json/read.clj b/src/clojure/contrib/json/read.clj deleted file mode 100644 index e9c7a3f2..00000000 --- a/src/clojure/contrib/json/read.clj +++ /dev/null @@ -1,338 +0,0 @@ -;;; json/read.clj: JavaScript Object Notation (JSON) parser - -;; by Stuart Sierra, http://stuartsierra.com/ -;; February 13, 2009 - -;; Copyright (c) Stuart Sierra, 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. - - -;; Change Log -;; -;; February 13, 2009: added custom handler for quoted strings, to -;; allow escaped forward backslash characters ("\/") in strings. -;; -;; January 26, 2009: initial version - - -;; For more information on JSON, see http://www.json.org/ -;; -;; This library parses data in JSON format. This is a fairly strict -;; implementation of JSON as described at json.org, not a full-fledged -;; JavaScript parser. JavaScript functions and object constructors -;; are not supported. Object field names must be quoted strings; they -;; may not be bare symbols. - - - -(ns - #^{:author "Stuart Sierra", - :doc "JavaScript Object Notation (JSON) parser - - For more information on JSON, see http://www.json.org/ - - This library parses data in JSON format. This is a fairly strict - implementation of JSON as described at json.org, not a full-fledged - JavaScript parser. JavaScript functions and object constructors - are not supported. Object field names must be quoted strings; they - may not be bare symbols. - - If you want to convert map keys from strings to keywords, use - clojure.contrib.walk/keywordize-keys -", - :see-also [["http://www.json.org", "JSON Home Page"]]} - clojure.contrib.json.read - (:import (java.io PushbackReader StringReader EOFException)) - (:use [clojure.test :only (deftest- is)])) - -(declare read-json) - -(def #^{:doc "If true, JSON object keys will be converted to keywords - instead of strings. Defaults to false. There are no checks that - the strings form valid keywords."} *json-keyword-keys* false) - -(defn- read-json-array [#^PushbackReader stream] - ;; Expects to be called with the head of the stream AFTER the - ;; opening bracket. - (loop [i (.read stream), result []] - (let [c (char i)] - (cond - (= i -1) (throw (EOFException. "JSON error (end-of-file inside array)")) - (Character/isWhitespace c) (recur (.read stream) result) - (= c \,) (recur (.read stream) result) - (= c \]) result - :else (do (.unread stream (int c)) - (let [element (read-json stream)] - (recur (.read stream) (conj result element)))))))) - -(defn- read-json-object [#^PushbackReader stream] - ;; Expects to be called with the head of the stream AFTER the - ;; opening bracket. - (loop [i (.read stream), key nil, result {}] - (let [c (char i)] - (cond - (= i -1) (throw (EOFException. "JSON error (end-of-file inside object)")) - - (Character/isWhitespace c) (recur (.read stream) key result) - - (= c \,) (recur (.read stream) nil result) - - (= c \:) (recur (.read stream) key result) - - (= c \}) (if (nil? key) - result - (throw (Exception. "JSON error (key missing value in object)"))) - - :else (do (.unread stream i) - (let [element (read-json stream)] - (if (nil? key) - (if (string? element) - (recur (.read stream) element result) - (throw (Exception. "JSON error (non-string key in object)"))) - (recur (.read stream) nil - (assoc result (if *json-keyword-keys* (keyword key) key) - element))))))))) - -(defn- read-json-hex-character [#^PushbackReader stream] - ;; Expects to be called with the head of the stream AFTER the - ;; initial "\u". Reads the next four characters from the stream. - (let [digits [(.read stream) - (.read stream) - (.read stream) - (.read stream)]] - (when (some neg? digits) - (throw (EOFException. "JSON error (end-of-file inside Unicode character escape)"))) - (let [chars (map char digits)] - (when-not (every? #{\0 \1 \2 \3 \4 \5 \6 \7 \8 \9 \a \b \c \d \e \f \A \B \C \D \E \F} - chars) - (throw (Exception. "JSON error (invalid hex character in Unicode character escape)"))) - (char (Integer/parseInt (apply str chars) 16))))) - -(defn- read-json-escaped-character [#^PushbackReader stream] - ;; Expects to be called with the head of the stream AFTER the - ;; initial backslash. - (let [c (char (.read stream))] - (cond - (#{\" \\ \/} c) c - (= c \b) \backspace - (= c \f) \formfeed - (= c \n) \newline - (= c \r) \return - (= c \t) \tab - (= c \u) (read-json-hex-character stream)))) - -(defn- read-json-quoted-string [#^PushbackReader stream] - ;; Expects to be called with the head of the stream AFTER the - ;; opening quotation mark. - (let [buffer (StringBuilder.)] - (loop [i (.read stream)] - (let [c (char i)] - (cond - (= i -1) (throw (EOFException. "JSON error (end-of-file inside string)")) - (= c \") (str buffer) - (= c \\) (do (.append buffer (read-json-escaped-character stream)) - (recur (.read stream))) - :else (do (.append buffer c) - (recur (.read stream)))))))) - -(defn read-json - "Read one JSON record from s, which may be a String or a - java.io.PushbackReader." - ([] (read-json *in* true nil)) - ([s] (if (string? s) - (read-json (PushbackReader. (StringReader. s)) true nil) - (read-json s true nil))) - ([#^PushbackReader stream eof-error? eof-value] - (loop [i (.read stream)] - (let [c (char i)] - (cond - ;; Handle end-of-stream - (= i -1) (if eof-error? - (throw (EOFException. "JSON error (end-of-file)")) - eof-value) - - ;; Ignore whitespace - (Character/isWhitespace c) (recur (.read stream)) - - ;; Read numbers, true, and false with Clojure reader - (#{\- \0 \1 \2 \3 \4 \5 \6 \7 \8 \9} c) - (do (.unread stream i) - (read stream true nil)) - - ;; Read strings - (= c \") (read-json-quoted-string stream) - - ;; Read null as nil - (= c \n) (let [ull [(char (.read stream)) - (char (.read stream)) - (char (.read stream))]] - (if (= ull [\u \l \l]) - nil - (throw (Exception. (str "JSON error (expected null): " c ull))))) - - ;; Read true - (= c \t) (let [rue [(char (.read stream)) - (char (.read stream)) - (char (.read stream))]] - (if (= rue [\r \u \e]) - true - (throw (Exception. (str "JSON error (expected true): " c rue))))) - - ;; Read false - (= c \f) (let [alse [(char (.read stream)) - (char (.read stream)) - (char (.read stream)) - (char (.read stream))]] - (if (= alse [\a \l \s \e]) - false - (throw (Exception. (str "JSON error (expected false): " c alse))))) - - - - ;; Read JSON objects - (= c \{) (read-json-object stream) - - ;; Read JSON arrays - (= c \[) (read-json-array stream) - - :else (throw (Exception. (str "JSON error (unexpected character): " c)))))))) - - -(defn read-json-string [string] - (read-json (PushbackReader. (StringReader. string)))) - - -;;; TESTS - -(deftest- can-read-numbers - (is (= 42 (read-json "42"))) - (is (= -3 (read-json "-3"))) - (is (= 3.14159 (read-json "3.14159"))) - (is (= 6.022e23 (read-json "6.022e23")))) - -(deftest- can-read-null - (is (= nil (read-json "null")))) - -(deftest- can-read-strings - (is (= "Hello, World!" (read-json "\"Hello, World!\"")))) - -(deftest- handles-escaped-slashes-in-strings - (is (= "/foo/bar" (read-json "\"\\/foo\\/bar\"")))) - -(deftest- handles-unicode-escapes - (is (= " \u0beb " (read-json "\" \\u0bEb \"")))) - -(deftest- handles-escaped-whitespace - (is (= "foo\nbar" (read-json "\"foo\\nbar\""))) - (is (= "foo\rbar" (read-json "\"foo\\rbar\""))) - (is (= "foo\tbar" (read-json "\"foo\\tbar\"")))) - -(deftest- can-read-booleans - (is (= true (read-json "true"))) - (is (= false (read-json "false")))) - -(deftest- can-ignore-whitespace - (is (= nil (read-json "\r\n null")))) - -(deftest- can-read-arrays - (is (= [1 2 3] (read-json "[1,2,3]"))) - (is (= ["Ole" "Lena"] (read-json "[\"Ole\", \r\n \"Lena\"]")))) - -(deftest- can-read-objects - (is (= {"a" 1, "b" 2} (read-json "{\"a\": 1, \"b\": 2}")))) - -(deftest- can-read-nested-structures - (is (= {"a" [1 2 {"b" [3 "four"]} 5.5]} - (read-json "{\"a\":[1,2,{\"b\":[3,\"four\"]},5.5]}")))) - -(deftest- disallows-non-string-keys - (is (thrown? Exception (read-json "{26:\"z\"")))) - -(deftest- disallows-barewords - (is (thrown? Exception (read-json " foo ")))) - -(deftest- disallows-unclosed-arrays - (is (thrown? Exception (read-json "[1, 2, ")))) - -(deftest- disallows-unclosed-objects - (is (thrown? Exception (read-json "{\"a\":1, ")))) - -(deftest- can-get-keyword-keys - (is (= {:a [1 2 {:b [3 "four"]} 5.5]} - (binding [*json-keyword-keys* true] - (read-json "{\"a\":[1,2,{\"b\":[3,\"four\"]},5.5]}"))))) - -(declare *pass1-string*) - -(deftest- pass1-test - (let [input (read-json *pass1-string*)] - (is (= "JSON Test Pattern pass1" (first input))) - (is (= "array with 1 element" (get-in input [1 "object with 1 member" 0]))) - (is (= 1234567890 (get-in input [8 "integer"]))) - (is (= "rosebud" (last input))))) - -; from http://www.json.org/JSON_checker/test/pass1.json -(def *pass1-string* - "[ - \"JSON Test Pattern pass1\", - {\"object with 1 member\":[\"array with 1 element\"]}, - {}, - [], - -42, - true, - false, - null, - { - \"integer\": 1234567890, - \"real\": -9876.543210, - \"e\": 0.123456789e-12, - \"E\": 1.234567890E+34, - \"\": 23456789012E66, - \"zero\": 0, - \"one\": 1, - \"space\": \" \", - \"quote\": \"\\\"\", - \"backslash\": \"\\\\\", - \"controls\": \"\\b\\f\\n\\r\\t\", - \"slash\": \"/ & \\/\", - \"alpha\": \"abcdefghijklmnopqrstuvwyz\", - \"ALPHA\": \"ABCDEFGHIJKLMNOPQRSTUVWYZ\", - \"digit\": \"0123456789\", - \"0123456789\": \"digit\", - \"special\": \"`1~!@#$%^&*()_+-={':[,]}|;.</>?\", - \"hex\": \"\\u0123\\u4567\\u89AB\\uCDEF\\uabcd\\uef4A\", - \"true\": true, - \"false\": false, - \"null\": null, - \"array\":[ ], - \"object\":{ }, - \"address\": \"50 St. James Street\", - \"url\": \"http://www.JSON.org/\", - \"comment\": \"// /* <!-- --\", - \"# -- --> */\": \" \", - \" s p a c e d \" :[1,2 , 3 - -, - -4 , 5 , 6 ,7 ],\"compact\":[1,2,3,4,5,6,7], - \"jsontext\": \"{\\\"object with 1 member\\\":[\\\"array with 1 element\\\"]}\", - \"quotes\": \"" \\u0022 %22 0x22 034 "\", - \"\\/\\\\\\\"\\uCAFE\\uBABE\\uAB98\\uFCDE\\ubcda\\uef4A\\b\\f\\n\\r\\t`1~!@#$%^&*()_+-=[]{}|;:',./<>?\" -: \"A key can be any string\" - }, - 0.5 ,98.6 -, -99.44 -, - -1066, -1e1, -0.1e1, -1e-1, -1e00,2e+00,2e-00 -,\"rosebud\"]")
\ No newline at end of file diff --git a/src/clojure/contrib/json/write.clj b/src/clojure/contrib/json/write.clj deleted file mode 100644 index 5f56f211..00000000 --- a/src/clojure/contrib/json/write.clj +++ /dev/null @@ -1,193 +0,0 @@ -;;; json/write.clj: JavaScript Object Notation (JSON) generator - -;; by Stuart Sierra, http://stuartsierra.com/ -;; May 9, 2009 - -;; Copyright (c) Stuart Sierra, 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. - - -(ns - #^{:author "Stuart Sierra", - :doc "JavaScript Object Notation (JSON) generator. - -This library will generate JSON from the following types: - * nil - * all primitives (Boolean, Byte, Short, Integer, Long, Float, Double) - * String (actually any CharSequence) - * java.util.Map (including Clojure maps) - * java.util.Collection (including Clojure vectors, lists, and sets) - * Java arrays - -You can extend this library to handle new types by adding methods to -print-json. - -This library does NOT attempt to preserve round-trip equality between -JSON and Clojure data types. That is, if you write a JSON string with -this library, then read it back with clojure.contrib.json.read, you -won't necessarily get the exact same data structure. For example, -Clojure sets are written as JSON arrays, which will be read back as -Clojure vectors. - -If you want indented output, try the clojure-json library at -http://github.com/danlarkin/clojure-json - -This implementation attempts to follow the description of JSON at -<http://json.org/>. Maps become JSON objects, all other collections -become JSON arrays. JSON object keys are always converted to strings. -Within strings, all non-ASCII characters are hexadecimal escaped. -", - :see-also [["http://json.org/", "JSON Home Page"]]} - clojure.contrib.json.write - (:require [clojure.contrib.java-utils :as j]) - (:use [clojure.test :only (deftest- is)])) - -(defmulti - #^{:doc "Prints x as JSON. Nil becomes JSON null. Keywords become - strings, without the leading colon. Maps become JSON objects, all - other collection types become JSON arrays. Java arrays become JSON - arrays. Unicode characters in strings are escaped as \\uXXXX. - Numbers print as with pr." - :arglists '([x])} - print-json (fn [x] (cond - (nil? x) nil ;; prevent NullPointerException on next line - (.isArray (class x)) ::array - :else (type x)))) - - -;; Primitive types can be printed with Clojure's pr function. -(derive java.lang.Boolean ::pr) -(derive java.lang.Byte ::pr) -(derive java.lang.Short ::pr) -(derive java.lang.Integer ::pr) -(derive java.lang.Long ::pr) -(derive java.lang.Float ::pr) -(derive java.lang.Double ::pr) - -;; Collection types can be printed as JSON objects or arrays. -(derive java.util.Map ::object) -(derive java.util.Collection ::array) - -;; Symbols and keywords are converted to strings. -(derive clojure.lang.Symbol ::symbol) -(derive clojure.lang.Keyword ::symbol) - - -(defmethod print-json ::pr [x] (pr x)) - -(defmethod print-json nil [x] (print "null")) - -(defmethod print-json ::symbol [x] (print-json (name x))) - -(defmethod print-json ::array [s] - (print \[) - (loop [x s] - (when (seq x) - (let [fst (first x) - nxt (next x)] - (print-json fst) - (when (seq nxt) - (print \,) - (recur nxt))))) - (print \])) - -(defmethod print-json ::object [m] - (print \{) - (loop [x m] - (when (seq m) - (let [[k v] (first x)] - (when (nil? k) - (throw (Exception. "JSON object keys cannot be nil/null"))) - (print-json (j/as-str k)) - (print \:) - (print-json v)) - (let [nxt (next x)] - (when (seq nxt) - (print \,) - (recur nxt))))) - (print \})) - -(defmethod print-json java.lang.CharSequence [#^CharSequence s] - (let [sb (StringBuilder. (count s))] - (.append sb \") - (dotimes [i (count s)] - (let [cp (Character/codePointAt s i)] - (cond - ;; Handle printable JSON escapes before ASCII - (= cp 34) (.append sb "\\\"") - (= cp 92) (.append sb "\\\\") - (= cp 47) (.append sb "\\/") - ;; Print simple ASCII characters - (< 31 cp 127) (.append sb (.charAt s i)) - ;; Handle non-printable JSON escapes - (= cp 8) (.append sb "\\b") - (= cp 12) (.append sb "\\f") - (= cp 10) (.append sb "\\n") - (= cp 13) (.append sb "\\r") - (= cp 9) (.append sb "\\t") - ;; Any other character is Hexadecimal-escaped - :else (.append sb (format "\\u%04x" cp))))) - (.append sb \") - (print (str sb)))) - -(defn json-str - "Converts x to a JSON-formatted string." - [x] - (with-out-str (print-json x))) - - - -;;; TESTS - -;; Run these tests with -;; (clojure.test/run-tests 'clojure.contrib.print-json) - -;; Bind clojure.test/*load-tests* to false to omit these -;; tests from production code. - -(deftest- can-print-json-strings - (is (= "\"Hello, World!\"" (json-str "Hello, World!"))) - (is (= "\"\\\"Embedded\\\" Quotes\"" (json-str "\"Embedded\" Quotes")))) - -(deftest- can-print-unicode - (is (= "\"\\u1234\\u4567\"" (json-str "\u1234\u4567")))) - -(deftest- can-print-json-null - (is (= "null" (json-str nil)))) - -(deftest- can-print-json-arrays - (is (= "[1,2,3]" (json-str [1 2 3]))) - (is (= "[1,2,3]" (json-str (list 1 2 3)))) - (is (= "[1,2,3]" (json-str (sorted-set 1 2 3)))) - (is (= "[1,2,3]" (json-str (seq [1 2 3]))))) - -(deftest- can-print-java-arrays - (is (= "[1,2,3]" (json-str (into-array [1 2 3]))))) - -(deftest- can-print-empty-arrays - (is (= "[]" (json-str []))) - (is (= "[]" (json-str (list)))) - (is (= "[]" (json-str #{})))) - -(deftest- can-print-json-objects - (is (= "{\"a\":1,\"b\":2}" (json-str (sorted-map :a 1 :b 2))))) - -(deftest- object-keys-must-be-strings - (is (= "{\"1\":1,\"2\":2") (json-str (sorted-map 1 1 2 2)))) - -(deftest- can-print-empty-objects - (is (= "{}" (json-str {})))) - -(deftest- accept-sequence-of-nils - (is (= "[null,null,null]" (json-str [nil nil nil])))) - -(deftest- error-on-nil-keys - (is (thrown? Exception (json-str {nil 1})))) - -(deftest- characters-in-symbols-are-escaped - (is (= "\"foo\\u1b1b\"" (json-str (symbol "foo\u1b1b")))))
\ No newline at end of file diff --git a/src/clojure/contrib/lazy_seqs.clj b/src/clojure/contrib/lazy_seqs.clj deleted file mode 100644 index dda5aac5..00000000 --- a/src/clojure/contrib/lazy_seqs.clj +++ /dev/null @@ -1,86 +0,0 @@ -;; Copyright (c) Stephen C. Gilardi. 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. -;; -;; lazy-seqs -;; -;; == Lazy sequences == -;; -;; primes - based on the "naive" implemention described in [1] plus a -;; small "wheel" which eliminates multiples of 2, 3, 5, and -;; 7 from consideration by incrementing past them. Also inspired -;; by code from Christophe Grand in [2]. -;; -;; fibs - all the Fibonacci numbers -;; -;; powers-of-2 - all the powers of 2 -;; -;; == Lazy sequence functions == -;; -;; (rotations, partition-all, shuffle, rand-elt moved to seq_utils.clj) -;; (permutations and combinations moved to combinatorics.clj) -;; -;; [1] http://www.cs.hmc.edu/~oneill/papers/Sieve-JFP.pdf -;; [2] http://clj-me.blogspot.com/2008/06/primes.html -;; -;; scgilardi (gmail) -;; Created 07 June 2008 - -(ns - #^{:author "Stephen C. Gilardi", - :doc " -==== Lazy sequences ==== - - primes - based on the \"naive\" implemention described in [1] plus a - small \"wheel\" which eliminates multiples of 2, 3, 5, and - 7 from consideration by incrementing past them. Also inspired - by code from Christophe Grand in [2]. - - fibs - all the Fibonacci numbers - - powers-of-2 - all the powers of 2 - - ==== Lazy sequence functions ==== - - (rotations, partition-all, shuffle, rand-elt moved to seq_utils.clj) - (permutations and combinations moved to combinatorics.clj) - - [1] http://www.cs.hmc.edu/~oneill/papers/Sieve-JFP.pdf - [2] http://clj-me.blogspot.com/2008/06/primes.html -"} - clojure.contrib.lazy-seqs - (:use clojure.contrib.def)) - -; primes cannot be written efficiently as a function, because -; it needs to look back on the whole sequence. contrast with -; fibs and powers-of-2 which only need a fixed buffer of 1 or 2 -; previous values. -(defvar primes - (concat - [2 3 5 7] - (lazy-seq - (let [primes-from - (fn primes-from [n [f & r]] - (if (some #(zero? (rem n %)) - (take-while #(<= (* % %) n) primes)) - (recur (+ n f) r) - (lazy-seq (cons n (primes-from (+ n f) r))))) - wheel (cycle [2 4 2 4 6 2 6 4 2 4 6 6 2 6 4 2 - 6 4 6 8 4 2 4 2 4 8 6 4 6 2 4 6 - 2 6 6 4 2 4 6 2 6 4 2 4 2 10 2 10])] - (primes-from 11 wheel)))) - "Lazy sequence of all the prime numbers.") - -(defn fibs - "Returns a lazy sequence of all the Fibonacci numbers." - [] - (map first (iterate (fn [[a b]] [b (+ a b)]) [0 1]))) - -(defn powers-of-2 - "Returns a lazy sequence of all the powers of 2" - [] - (iterate #(bit-shift-left % 1) 1)) diff --git a/src/clojure/contrib/lazy_xml.clj b/src/clojure/contrib/lazy_xml.clj deleted file mode 100644 index 8b385b93..00000000 --- a/src/clojure/contrib/lazy_xml.clj +++ /dev/null @@ -1,189 +0,0 @@ -; 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. - -; Functions to parse xml lazily and emit back to text. - -(ns - #^{:author "Chris Houser", - :doc "Functions to parse xml lazily and emit back to text."} - clojure.contrib.lazy-xml - (:use [clojure.xml :as xml :only []] - [clojure.contrib.seq-utils :only [fill-queue]]) - (:import (org.xml.sax Attributes InputSource) - (org.xml.sax.helpers DefaultHandler) - (javax.xml.parsers SAXParserFactory) - (java.util.concurrent LinkedBlockingQueue TimeUnit) - (java.lang.ref WeakReference) - (java.io Reader))) - -(defstruct node :type :name :attrs :str) - -; http://www.extreme.indiana.edu/xgws/xsoap/xpp/ -(def has-pull false) -(defn- parse-seq-pull [& _]) -(try - (load "lazy_xml/with_pull") - (catch Exception e - (when-not (re-find #"XmlPullParser" (str e)) - (throw e)))) - -(defn startparse-sax [s ch] - (.. SAXParserFactory newInstance newSAXParser (parse s ch))) - -(defn parse-seq - "Parses the source s, which can be a File, InputStream or String - naming a URI. Returns a lazy sequence of maps with two or more of - the keys :type, :name, :attrs, and :str. Other SAX-compatible - parsers can be supplied by passing startparse, a fn taking a source - and a ContentHandler and returning a parser. If a parser is - specified, it will be run in a separate thread and be allowed to get - ahead by queue-size items, which defaults to maxint. If no parser - is specified and org.xmlpull.v1.XmlPullParser is in the classpath, - this superior pull parser will be used." - ([s] (if has-pull - (parse-seq-pull s) - (parse-seq s startparse-sax))) - ([s startparse] (parse-seq s startparse Integer/MAX_VALUE)) - ([s startparse queue-size] - (let [s (if (instance? Reader s) (InputSource. s) s) - f (fn filler-func [fill] - (startparse s (proxy [DefaultHandler] [] - (startElement [uri local-name q-name #^Attributes atts] - ;(prn :start-element q-name)(flush) - (let [attrs (into {} (for [i (range (.getLength atts))] - [(keyword (.getQName atts i)) - (.getValue atts i)]))] - (fill (struct node :start-element (keyword q-name) attrs)))) - (endElement [uri local-name q-name] - ;(prn :end-element q-name)(flush) - (fill (struct node :end-element (keyword q-name)))) - (characters [ch start length] - ;(prn :characters)(flush) - (let [st (String. ch start length)] - (when (seq (.trim st)) - (fill (struct node :characters nil nil st))))))))] - (fill-queue f :queue-size queue-size)))) - - -(defstruct element :tag :attrs :content) -(declare mktree) - -(defn- siblings [coll] - (lazy-seq - (when-let [s (seq coll)] - (let [event (first s)] - (condp = (:type event) - :characters (cons (:str event) (siblings (rest s))) - :start-element (let [t (mktree s)] - (cons (first t) (siblings (rest t)))) - :end-element [(rest s)]))))) - -(defn- mktree - [[elem & events]] - (lazy-seq - (let [sibs (siblings events)] - ;(prn :elem elem) - (cons - (struct element (:name elem) (:attrs elem) (drop-last sibs)) - (lazy-seq (last sibs)))))) - -(defn parse-trim - "Parses the source s, which can be a File, InputStream or String - naming a URI. Returns a lazy tree of the clojure.xml/element - struct-map, which has the keys :tag, :attrs, and :content and - accessor fns tag, attrs, and content, with the whitespace trimmed - from around each content string. This format is compatible with what - clojure.xml/parse produces, except :content is a lazy seq instead of - a vector. Other SAX-compatible parsers can be supplied by passing - startparse, a fn taking a source and a ContentHandler and returning - a parser. If a parser is specified, it will be run in a separate - thread and be allowed to get ahead by queue-size items, which - defaults to maxing. If no parser is specified and - org.xmlpull.v1.XmlPullParser is in the classpath, this superior pull - parser will be used." - ([s] (first (mktree (parse-seq s)))) - ([s startparse queue-size] - (first (mktree (parse-seq s startparse queue-size))))) - -(def escape-xml-map (zipmap "'<>\"&" (map #(str \& % \;) '[apos lt gt quot amp]))) - -(defn escape-xml [text] - (apply str (map #(escape-xml-map % %) text))) - -(defn emit-element - "Recursively prints as XML text the element struct e. To have it - print extra whitespace like clojure.xml/emit, use the :pad true - option." - [e & opts] - (let [opts (apply hash-set opts) - pad (if (:pad opts) "\n" "")] - (if (instance? String e) - (print (str (escape-xml e) pad)) - (do - (print (str "<" (name (:tag e)))) - (when (:attrs e) - (doseq [attr (:attrs e)] - (print (str " " (name (key attr)) - "='" (escape-xml (val attr)) "'")))) - (if (seq (:content e)) - (do - (print (str ">" pad)) - (doseq [c (:content e)] - (emit-element c)) - (print (str "</" (name (:tag e)) ">" pad))) - (print (str "/>" pad))))))) - -(defn emit - "Prints an <?xml?> declaration line, and then calls emit-element" - [x & opts] - (println "<?xml version='1.0' encoding='UTF-8'?>") - (apply emit-element x opts) - (println)) - -(comment - -(def atomstr "<?xml version='1.0' encoding='UTF-8'?> -<feed xmlns='http://www.w3.org/2005/Atom'> - <id>tag:blogger.com,1999:blog-28403206</id> - <updated>2008-02-14T08:00:58.567-08:00</updated> - <title type='text'>n01senet</title> - <link rel='alternate' type='text/html' href='http://n01senet.blogspot.com/'/> - <entry xmlns:foo='http://foo' xmlns:bar='http://bar'> - <id>1</id> - <published>2008-02-13</published> - <title type='text'>clojure is the best lisp yet</title> - <author><name>Chouser</name></author> - </entry> - <entry> - <id>2</id> - <published>2008-02-07</published> - <title type='text'>experimenting with vnc</title> - <author><name>agriffis</name></author> - </entry> -</feed> -") - -(def tree (parse-trim (java.io.StringReader. atomstr) - startparse-sax - 1)) -(println "\nsax") -(emit tree) - -(def tree (parse-trim (java.io.StringReader. atomstr))) -(println "\ndefault") -(emit tree) - -(def tree (xml/parse (org.xml.sax.InputSource. (java.io.StringReader. atomstr)))) -(println "\norig") -(emit tree) - -; When used with zip and zip-filter, you can get do queries like this -; without parsing more than the first few tags: -; (zip/node (first (xml-> (zip/xml-zip tree) :id))) - -) diff --git a/src/clojure/contrib/lazy_xml/with_pull.clj b/src/clojure/contrib/lazy_xml/with_pull.clj deleted file mode 100644 index 06181569..00000000 --- a/src/clojure/contrib/lazy_xml/with_pull.clj +++ /dev/null @@ -1,58 +0,0 @@ -; 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/src/clojure/contrib/load_all.clj b/src/clojure/contrib/load_all.clj deleted file mode 100644 index 7a38230a..00000000 --- a/src/clojure/contrib/load_all.clj +++ /dev/null @@ -1,91 +0,0 @@ -;;; load_all.clj - loads all contrib libraries for testing purposes - -;; by Stuart Sierra, http://stuartsierra.com/ -;; February 21, 2009 - -;; Copyright (c) Stuart Sierra, 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 file simple attempts to "require" every library in -;; clojure-contrib. The names of all contrib libs (minus the -;; "clojure.contrib" part) are in *all-contrib-libs*. Libraries which -;; throw errors when loading under the latest trunk SVN revisions of -;; Clojure and clojure-contrib are commented out. -;; -;; This is only intended to check that the libraries will load without -;; errors, not that they work correctly. If the libraries have tests -;; defined using test-is, you can run them with: -;; -;; (clojure.test/run-all-tests) -;; -;; If you write a new lib, please add it to the list in this file. - - -(ns clojure.contrib.load-all) - -(def *all-contrib-libs* '[ -accumulators -apply-macro -combinatorics -command-line -complex-numbers -cond -def -duck-streams -error-kit -except -fcase -generic -generic.arithmetic -generic.collection -generic.comparison -generic.functor -generic.math-functions -import-static -jar -;; javadoc - moved to repl-utils -javadoc.browse -;; javalog -json.read -json.write -lazy-seqs -lazy-xml -macro-utils -macros -math -miglayout -mmap -monads -ns-utils -pprint -probabilities.finite-distributions -probabilities.monte-carlo -probabilities.random-numbers -prxml -repl-ln -repl-utils -seq-utils -server-socket -set -shell-out -sql -str-utils -str-utils2 -stream-utils -swing-utils -test-contrib -test-contrib.shell-out -test-contrib.str-utils -trace -types -zip-filter -]) - -(doseq [name *all-contrib-libs*] - (require (symbol (str "clojure.contrib." name)))) diff --git a/src/clojure/contrib/logging.clj b/src/clojure/contrib/logging.clj deleted file mode 100644 index 97bbfcfe..00000000 --- a/src/clojure/contrib/logging.clj +++ /dev/null @@ -1,349 +0,0 @@ -;;; logging.clj -- delegated logging for Clojure - -;; by Alex Taggart -;; July 27, 2009 - -;; Copyright (c) Alex Taggart, July 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. -(ns - #^{:author "Alex Taggart, Timothy Pratley", - :doc - "Logging macros which delegate to a specific logging implementation. At - macro-expansion-time a specific implementation is selected from, in order, - Apache commons-logging, log4j, and finally java.util.logging. - - Logging levels are specified by clojure keywords corresponding to the - values used in log4j and commons-logging: - :trace, :debug, :info, :warn, :error, :fatal - - Logging occurs with the log macro, or the level-specific convenience macros, - which write either directly or via an agent. For performance reasons, direct - logging is enabled by default, but setting the *allow-direct-logging* boolean - atom to false will disable it. If logging is invoked within a transaction it - will always use an agent. - - The log macros will not evaluate their 'message' unless the specific logging - level is in effect. Alternately, you can use the spy macro when you have code - that needs to be evaluated, and also want to output the code and its result to - the debug log. - - Unless otherwise specified, the current namespace (as identified by *ns*) will - be used as the log-ns (similar to how the java class name is usually used). - Note: your log configuration should display the name that was passed to the - logging implementation, and not perform stack-inspection, otherwise you'll see - something like \"fn__72$impl_write_BANG__39__auto____81\" in your logs. - - Use the enabled? macro to write conditional code against the logging level - (beyond simply whether or not to call log, which is handled automatically). - - You can redirect all java writes of System.out and System.err to the log - system by calling log-capture!. To rebind *out* and *err* to the log system - invoke with-logs. In both cases a log-ns (e.g., \"com.example.captured\") - needs to be specified to namespace the output."} - clojure.contrib.logging) - -(declare *impl-name* impl-get-log impl-enabled? impl-write!) - -;; Macros used so that implementation-specific functions all have the same meta. - -(defmacro def-impl-name - {:private true} [& body] - `(def - #^{:doc "The name of the logging implementation used."} - *impl-name* - ~@body)) - -(defmacro def-impl-get-log - {:private true} [& body] - `(def - #^{:doc - "Returns an implementation-specific log by string namespace. End-users should - not need to call this function." - :arglist '([~'log-ns])} - impl-get-log - (memoize ~@body))) - -(defmacro def-impl-enabled? - {:private true} [& body] - `(def - #^{:doc - "Implementation-specific check if a particular level is enabled. End-users - should not need to call this function." - :arglist '([~'log ~'level])} - impl-enabled? - ~@body)) - -(defmacro def-impl-write! - {:private true} [& body] - `(def - #^{:doc - "Implementation-specific write of a log message. End-users should not need to - call this function." - :arglist '([~'log ~'level ~'message ~'throwable])} - impl-write! - ~@body)) - -(defmacro commons-logging - "Defines the commons-logging-based implementations of the core logging - functions. End-users should never need to call this macro." - {:private true} - [] - (try - (import (org.apache.commons.logging LogFactory Log)) - `(do - (def-impl-name "org.apache.commons.logging") - (def-impl-get-log - (fn [log-ns#] - (org.apache.commons.logging.LogFactory/getLog #^String log-ns#))) - (def-impl-enabled? - (fn [#^org.apache.commons.logging.Log log# level#] - (condp = level# - :trace (.isTraceEnabled log#) - :debug (.isDebugEnabled log#) - :info (.isInfoEnabled log#) - :warn (.isWarnEnabled log#) - :error (.isErrorEnabled log#) - :fatal (.isFatalEnabled log#)))) - (def-impl-write! - (fn [#^org.apache.commons.logging.Log log# level# msg# e#] - (condp = level# - :trace (.trace log# msg# e#) - :debug (.debug log# msg# e#) - :info (.info log# msg# e#) - :warn (.warn log# msg# e#) - :error (.error log# msg# e#) - :fatal (.fatal log# msg# e#)))) - true) - (catch Exception e nil))) - - -(defmacro log4j-logging - "Defines the log4j-based implementations of the core logging functions. - End-users should never need to call this macro." - {:private true} - [] - (try - (import (org.apache.log4j Logger Level)) - `(do - (def-impl-name "org.apache.log4j") - (def-impl-get-log - (fn [log-ns#] - (org.apache.log4j.Logger/getLogger #^String log-ns#))) - (let [levels# {:trace org.apache.log4j.Level/TRACE - :debug org.apache.log4j.Level/DEBUG - :info org.apache.log4j.Level/INFO - :warn org.apache.log4j.Level/WARN - :error org.apache.log4j.Level/ERROR - :fatal org.apache.log4j.Level/FATAL}] - (def-impl-enabled? - (fn [#^org.apache.log4j.Logger log# level#] - (.isEnabledFor log# (levels# level#)))) - (def-impl-write! - (fn [#^org.apache.log4j.Logger log# level# msg# e#] - (if-not e# - (.log log# (levels# level#) msg#) - (.log log# (levels# level#) msg# e#))))) - true) - (catch Exception e nil))) - - -(defmacro java-logging - "Defines the java-logging-based implementations of the core logging - functions. End-users should never need to call this macro." - {:private true} - [] - (try - (import (java.util.logging Logger Level)) - `(do - (def-impl-name "java.util.logging") - (def-impl-get-log - (fn [log-ns#] - (java.util.logging.Logger/getLogger log-ns#))) - (let [levels# {:trace java.util.logging.Level/FINEST - :debug java.util.logging.Level/FINE - :info java.util.logging.Level/INFO - :warn java.util.logging.Level/WARNING - :error java.util.logging.Level/SEVERE - :fatal java.util.logging.Level/SEVERE}] - (def-impl-enabled? - (fn [#^java.util.logging.Logger log# level#] - (.isLoggable log# (levels# level#)))) - (def-impl-write! - (fn [#^java.util.logging.Logger log# level# msg# e#] - (if-not e# - (.log log# #^java.util.logging.Level (levels# level#) - #^String (str msg#)) - (.log log# #^java.util.logging.Level (levels# level#) - #^String (str msg#) #^Throwable e#))))) - true) - (catch Exception e nil))) - - -;; Initialize implementation-specific functions -(or (commons-logging) - (log4j-logging) - (java-logging) - (throw ; this should never happen in 1.5+ - (RuntimeException. - "Valid logging implementation could not be found."))) - - -(def #^{:doc - "The default agent used for performing logging durng a transaction or when - direct logging is disabled."} - *logging-agent* (agent nil)) - - -(def #^{:doc - "A boolean indicating whether direct logging (as opposed to via an agent) is - allowed when not operating from within a transaction. Defaults to true."} - *allow-direct-logging* (atom true)) - - -(defn agent-write! - "Writes the message immediately, and ignores the first argument. Used by the - logging agent. End-users should never need to call this function." - [_ log level message throwable] - (impl-write! log level message throwable)) - - -(defmacro log - "Logs a message, either directly or via an agent. Also see the level-specific - convenience macros." - ([level message] - `(log ~level ~message nil)) - ([level message throwable] - `(log ~level ~message ~throwable ~(str *ns*))) - ([level message throwable log-ns] - `(let [log# (impl-get-log ~log-ns)] - (if (impl-enabled? log# ~level) - (if (and @*allow-direct-logging* - (not (clojure.lang.LockingTransaction/isRunning))) - (impl-write! log# ~level ~message ~throwable) - (send-off *logging-agent* - agent-write! log# ~level ~message ~throwable)))))) - - -(defmacro enabled? - "Returns true if the specific logging level is enabled. Use of this function - should only be necessary if one needs to execute alternate code paths beyond - whether the log should be written to." - ([level] - `(enabled? ~level ~(str *ns*))) - ([level log-ns] - `(impl-enabled? (impl-get-log ~log-ns) ~level))) - - -(defmacro spy - "Evaluates expr and outputs the form and its result to the debug log; returns - the result of expr." - [expr] - `(let [a# ~expr] (log :debug (str '~expr " => " a#)) a#)) - - -(defn log-stream - "Creates a PrintStream that will output to the log. End-users should not need - to invoke this function." - [level log-ns] - (java.io.PrintStream. - (proxy [java.io.ByteArrayOutputStream] [] - (flush [] - (proxy-super flush) - (let [s (.trim (.toString #^java.io.ByteArrayOutputStream this))] - (proxy-super reset) - (if (> (.length s) 0) - (log level s nil log-ns))))) - true)) - - -(def #^{:doc - "A ref used by log-capture! to maintain a reference to the original System.out - and System.err streams." - :private true} - *old-std-streams* (ref nil)) - - -(defn log-capture! - "Captures System.out and System.err, redirecting all writes of those streams - to :info and :error logging, respectively. The specified log-ns value will - be used to namespace all redirected logging. NOTE: this will not redirect - output of *out* or *err*; for that, use with-logs." - [log-ns] - (dosync - (let [new-out (log-stream :info log-ns) - new-err (log-stream :error log-ns)] - ; don't overwrite the original values - (if (nil? @*old-std-streams*) - (ref-set *old-std-streams* {:out System/out :err System/err})) - (System/setOut new-out) - (System/setErr new-err)))) - - -(defn log-uncapture! - "Restores System.out and System.err to their original values." - [] - (dosync - (when-let [{old-out :out old-err :err} @*old-std-streams*] - (ref-set *old-std-streams* nil) - (System/setOut old-out) - (System/setErr old-err)))) - - -(defmacro with-logs - "Evaluates exprs in a context in which *out* and *err* are bound to :info and - :error logging, respectively. The specified log-ns value will be used to - namespace all redirected logging." - [log-ns & body] - (if (and log-ns (seq body)) - `(binding [*out* (java.io.OutputStreamWriter. - (log-stream :info ~log-ns)) - *err* (java.io.OutputStreamWriter. - (log-stream :error ~log-ns))] - ~@body))) - -(defmacro trace - "Logs a message at the trace level." - ([message] - `(log :trace ~message)) - ([message throwable] - `(log :trace ~message ~throwable))) - -(defmacro debug - "Logs a message at the debug level." - ([message] - `(log :debug ~message)) - ([message throwable] - `(log :debug ~message ~throwable))) - -(defmacro info - "Logs a message at the info level." - ([message] - `(log :info ~message)) - ([message throwable] - `(log :info ~message ~throwable))) - -(defmacro warn - "Logs a message at the warn level." - ([message] - `(log :warn ~message)) - ([message throwable] - `(log :warn ~message ~throwable))) - -(defmacro error - "Logs a message at the error level." - ([message] - `(log :error ~message)) - ([message throwable] - `(log :error ~message ~throwable))) - -(defmacro fatal - "Logs a message at the fatal level." - ([message] - `(log :fatal ~message)) - ([message throwable] - `(log :fatal ~message ~throwable))) diff --git a/src/clojure/contrib/macro_utils.clj b/src/clojure/contrib/macro_utils.clj deleted file mode 100644 index 37ab3b88..00000000 --- a/src/clojure/contrib/macro_utils.clj +++ /dev/null @@ -1,270 +0,0 @@ -;; Macrolet and symbol-macrolet - -;; by Konrad Hinsen -;; last updated January 14, 2010 - -;; Copyright (c) Konrad Hinsen, 2009-2010. 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. - -(ns - #^{:author "Konrad Hinsen" - :doc "Local macros and symbol macros - - Local macros are defined by a macrolet form. They are usable only - inside its body. Symbol macros can be defined globally - (defsymbolmacro) or locally (symbol-macrolet). A symbol - macro defines a form that replaces a symbol during macro - expansion. Function arguments and symbols bound in let - forms are not subject to symbol macro expansion. - - Local macros are most useful in the definition of the expansion - of another macro, they may be used anywhere. Global symbol - macros can be used only inside a with-symbol-macros form."} - clojure.contrib.macro-utils - (:use [clojure.contrib.def :only (defvar-)])) - -; A set of all special forms. Special forms are not macro-expanded, making -; it impossible to shadow them by macro definitions. For most special -; forms, all the arguments are simply macro-expanded, but some forms -; get special treatment. -(defvar- special-forms - (into #{} (keys clojure.lang.Compiler/specials))) -; Value in the Clojure 1.2 branch: -; #{deftype* new quote & var set! monitor-enter recur . case* clojure.core/import* reify* do fn* throw monitor-exit letfn* finally let* loop* try catch if def} - -; The following three vars are constantly redefined using the binding -; form, imitating dynamic scoping. -; -; Local macros. -(defvar- macro-fns {}) -; Local symbol macros. -(defvar- macro-symbols {}) -; Symbols defined inside let forms or function arguments. -(defvar- protected-symbols #{}) - -(defn- reserved? - [symbol] - "Return true if symbol is a reserved symbol (starting or ending with a dot)." - (let [s (str symbol)] - (or (= "." (subs s 0 1)) - (= "." (subs s (dec (count s))))))) - -(defn- expand-symbol - "Expand symbol macros" - [symbol] - (cond (contains? protected-symbols symbol) symbol - (reserved? symbol) symbol - (contains? macro-symbols symbol) (get macro-symbols symbol) - :else (let [v (resolve symbol) - m (meta v)] - (if (:symbol-macro m) - (var-get v) - symbol)))) - -(defn- expand-1 - "Perform a single non-recursive macro expansion of form." - [form] - (cond - (seq? form) - (let [f (first form)] - (cond (contains? special-forms f) form - (contains? macro-fns f) (apply (get macro-fns f) (rest form)) - (symbol? f) (let [exp (expand-symbol f)] - (if (= exp f) - (clojure.core/macroexpand-1 form) - (cons exp (rest form)))) - ; handle defmacro macros and Java method special forms - :else (clojure.core/macroexpand-1 form))) - (symbol? form) - (expand-symbol form) - :else - form)) - -(defn- expand - "Perform repeated non-recursive macro expansion of form, until it no - longer changes." - [form] - (let [ex (expand-1 form)] - (if (identical? ex form) - form - (recur ex)))) - -(declare expand-all) - -(defn- expand-args - "Recursively expand the arguments of form, leaving its first - n elements unchanged." - ([form] - (expand-args form 1)) - ([form n] - (doall (concat (take n form) (map expand-all (drop n form)))))) - -(defn- expand-bindings - [bindings exprs] - (if (empty? bindings) - (list (doall (map expand-all exprs))) - (let [[[s b] & bindings] bindings] - (let [b (expand-all b)] - (binding [protected-symbols (conj protected-symbols s)] - (doall (cons [s b] (expand-bindings bindings exprs)))))))) - -(defn- expand-with-bindings - "Handle let* and loop* forms. The symbols defined in them are protected - from symbol macro expansion, the definitions and the body expressions - are expanded recursively." - [form] - (let [f (first form) - bindings (partition 2 (second form)) - exprs (rest (rest form)) - expanded (expand-bindings bindings exprs) - bindings (vec (apply concat (butlast expanded))) - exprs (last expanded)] - (cons f (cons bindings exprs)))) - -(defn- expand-fn-body - [[args & exprs]] - (binding [protected-symbols (reduce conj protected-symbols - (filter #(not (= % '&)) args))] - (cons args (doall (map expand-all exprs))))) - -(defn- expand-fn - "Handle fn* forms. The arguments are protected from symbol macro - expansion, the bodies are expanded recursively." - [form] - (let [[f & bodies] form - name (when (symbol? (first bodies)) (first bodies)) - bodies (if (symbol? (first bodies)) (rest bodies) bodies) - bodies (if (vector? (first bodies)) (list bodies) bodies) - bodies (doall (map expand-fn-body bodies))] - (if (nil? name) - (cons f bodies) - (cons f (cons name bodies))))) - -(defn- expand-method - "Handle a method in a deftype* or reify* form." - [m] - (rest (expand-fn (cons 'fn* m)))) - -(defn- expand-deftype - "Handle deftype* forms." - [[symbol typename classname fields implements interfaces & methods]] - (assert (= implements :implements)) - (let [expanded-methods (map expand-method methods)] - (concat - (list symbol typename classname fields implements interfaces) - expanded-methods))) - -(defn- expand-reify - "Handle reify* forms." - [[symbol interfaces & methods]] - (let [expanded-methods (map expand-method methods)] - (cons symbol (cons interfaces expanded-methods)))) - -; Handlers for special forms that require special treatment. The default -; is expand-args. -(defvar- special-form-handlers - {'quote identity - 'var identity - 'def #(expand-args % 2) - 'new #(expand-args % 2) - 'let* expand-with-bindings - 'loop* expand-with-bindings - 'fn* expand-fn - 'deftype* expand-deftype - 'reify* expand-reify}) - -(defn- expand-list - "Recursively expand a form that is a list or a cons." - [form] - (let [f (first form)] - (if (symbol? f) - (if (contains? special-forms f) - ((get special-form-handlers f expand-args) form) - (expand-args form)) - (doall (map expand-all form))))) - -(defn- expand-all - "Expand a form recursively." - [form] - (let [exp (expand form)] - (cond (symbol? exp) exp - (seq? exp) (expand-list exp) - (vector? exp) (into [] (map expand-all exp)) - (map? exp) (into {} (map expand-all (seq exp))) - :else exp))) - -(defmacro macrolet - "Define local macros that are used in the expansion of exprs. The - syntax is the same as for letfn forms." - [fn-bindings & exprs] - (let [names (map first fn-bindings) - name-map (into {} (map (fn [n] [(list 'quote n) n]) names)) - macro-map (eval `(letfn ~fn-bindings ~name-map))] - (binding [macro-fns (merge macro-fns macro-map) - macro-symbols (apply dissoc macro-symbols names)] - `(do ~@(doall (map expand-all exprs)))))) - -(defmacro symbol-macrolet - "Define local symbol macros that are used in the expansion of exprs. - The syntax is the same as for let forms." - [symbol-bindings & exprs] - (let [symbol-map (into {} (map vec (partition 2 symbol-bindings))) - names (keys symbol-map)] - (binding [macro-fns (apply dissoc macro-fns names) - macro-symbols (merge macro-symbols symbol-map)] - `(do ~@(doall (map expand-all exprs)))))) - -(defmacro defsymbolmacro - "Define a symbol macro. Because symbol macros are not part of - Clojure's built-in macro expansion system, they can be used only - inside a with-symbol-macros form." - [symbol expansion] - (let [meta-map (if (meta symbol) (meta symbol) {}) - meta-map (assoc meta-map :symbol-macro true)] - `(def ~(with-meta symbol meta-map) (quote ~expansion)))) - -(defmacro with-symbol-macros - "Fully expand exprs, including symbol macros." - [& exprs] - `(do ~@(doall (map expand-all exprs)))) - -(defmacro deftemplate - "Define a macro that expands into forms after replacing the - symbols in params (a vector) by the corresponding parameters - given in the macro call." - [name params & forms] - (let [param-map (for [p params] (list (list 'quote p) (gensym))) - template-params (vec (map second param-map)) - param-map (vec (apply concat param-map)) - expansion (list 'list (list 'quote `symbol-macrolet) param-map - (list 'quote (cons 'do forms)))] - `(defmacro ~name ~template-params ~expansion))) - -(defn mexpand-1 - "Like clojure.core/macroexpand-1, but takes into account symbol macros." - [form] - (binding [macro-fns {} - macro-symbols {} - protected-symbols #{}] - (expand-1 form))) - -(defn mexpand - "Like clojure.core/macroexpand, but takes into account symbol macros." - [form] - (binding [macro-fns {} - macro-symbols {} - protected-symbols #{}] - (expand form))) - -(defn mexpand-all - "Perform a full recursive macro expansion of a form." - [form] - (binding [macro-fns {} - macro-symbols {} - protected-symbols #{}] - (expand-all form))) diff --git a/src/clojure/contrib/macros.clj b/src/clojure/contrib/macros.clj deleted file mode 100644 index ffb67183..00000000 --- a/src/clojure/contrib/macros.clj +++ /dev/null @@ -1,84 +0,0 @@ -;; Various useful macros -;; -;; Everybody is invited to add their own little macros here! -;; -;; 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. - -(ns - #^{:author "Konrad Hinsen" - :doc "Various small macros"} - clojure.contrib.macros) - -;; By Konrad Hinsen -(defmacro const - "Evaluate the constant expression expr at compile time." - [expr] - (eval expr)) - -;; By Konrad Hinsen -; This macro is made obsolete by Clojure's built-in letfn. I renamed it to -; letfn- (to avoid a name clash) but leave it in for a while, since its -; syntax is not quite the same as Clojure's. Expect this to disappear -; in the long run! -(defmacro letfn- - "OBSOLETE: use clojure.core/letfn - A variant of let for local function definitions. fn-bindings consists - of name/args/body triples, with (letfn [name args body] ...) - being equivalent to (let [name (fn name args body)] ...)." - [fn-bindings & exprs] - (let [makefn (fn [[name args body]] (list name (list 'fn name args body))) - fns (vec (apply concat (map makefn (partition 3 fn-bindings))))] - `(let ~fns ~@exprs))) - - ;; By Konrad Hinsen - - (defn- unqualified-symbol - [s] - (let [s-str (str s)] - (symbol (subs s-str (inc (.indexOf s-str (int \/))))))) - -(defn- bound-var? - [var] - (try - (do (deref var) true) - (catch java.lang.IllegalStateException e false))) - -(defn- fns-from-ns - [ns ns-symbol] - (apply concat - (for [[k v] (ns-publics ns) - :when (and (bound-var? v) - (fn? @v) - (not (:macro (meta v))))] - [k (symbol (str ns-symbol) (str k))]))) - -(defn- expand-symbol - [ns-or-var-sym] - (if (= ns-or-var-sym '*ns*) - (fns-from-ns *ns* (ns-name *ns*)) - (if-let [ns (find-ns ns-or-var-sym)] - (fns-from-ns ns ns-or-var-sym) - (list (unqualified-symbol ns-or-var-sym) ns-or-var-sym)))) - -(defmacro with-direct-linking - "EXPERIMENTAL! - Compiles the functions in body with direct links to the functions - named in symbols, i.e. without a var lookup for each invocation. - Symbols is a vector of symbols that name either vars or namespaces. - A namespace reference is replaced by the list of all symbols in the - namespace that are bound to functions. If symbols is not provided, - the default value ['clojure.core] is used. The symbol *ns* can be - used to refer to the current namespace." - {:arglists '([symbols? & body])} - [& body] - (let [[symbols body] (if (vector? (first body)) - [(first body) (rest body)] - [['clojure.core] body]) - bindings (vec (mapcat expand-symbol symbols))] - `(let ~bindings ~@body))) -
\ No newline at end of file diff --git a/src/clojure/contrib/map_utils.clj b/src/clojure/contrib/map_utils.clj deleted file mode 100644 index 4adf3068..00000000 --- a/src/clojure/contrib/map_utils.clj +++ /dev/null @@ -1,55 +0,0 @@ -;; Copyright (c) Jason Wolfe. 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. -;; -;; map_utils.clj -;; -;; Utilities for operating on Clojure maps. -;; -;; jason at w01fe dot com -;; Created 25 Feb 2009 - -(ns - #^{:author "Jason Wolfe, Chris Houser", - :doc "Utilities for operating on Clojure maps."} - clojure.contrib.map-utils) - - -(defmacro lazy-get - "Like get, but doesn't evaluate not-found unless it is needed." - [map key not-found] - `(if-let [pair# (find ~map ~key)] - (val pair#) - ~not-found)) - -(defn safe-get - "Like get, but throws an exception if the key is not found." - [map key] - (lazy-get map key - (throw (IllegalArgumentException. (format "Key %s not found in %s" key map))))) - -(defn safe-get-in - "Like get-in, but throws an exception if any key is not found." - [map ks] - (reduce safe-get map ks)) - -; by Chouser: -(defn deep-merge-with - "Like merge-with, but merges maps recursively, applying the given fn - only when there's a non-map at a particular level. - - (deepmerge + {:a {:b {:c 1 :d {:x 1 :y 2}} :e 3} :f 4} - {:a {:b {:c 2 :d {:z 9} :z 3} :e 100}}) - -> {:a {:b {:z 3, :c 3, :d {:z 9, :x 1, :y 2}}, :e 103}, :f 4}" - [f & maps] - (apply - (fn m [& maps] - (if (every? map? maps) - (apply merge-with m maps) - (apply f maps))) - maps)) - diff --git a/src/clojure/contrib/math.clj b/src/clojure/contrib/math.clj deleted file mode 100644 index cef32bf2..00000000 --- a/src/clojure/contrib/math.clj +++ /dev/null @@ -1,247 +0,0 @@ -;;; math.clj: math functions that deal intelligently with the various
-;;; types in Clojure's numeric tower, as well as math functions
-;;; commonly found in Scheme implementations.
-
-;; by Mark Engelberg (mark.engelberg@gmail.com)
-;; January 17, 2009
-
-;; expt - (expt x y) is x to the yth power, returns an exact number
-;; if the base is an exact number, and the power is an integer,
-;; otherwise returns a double.
-;; abs - (abs n) is the absolute value of n
-;; gcd - (gcd m n) returns the greatest common divisor of m and n
-;; lcm - (lcm m n) returns the least common multiple of m and n
-
-;; The behavior of the next three functions on doubles is consistent
-;; with the behavior of the corresponding functions
-;; in Java's Math library, but on exact numbers, returns an integer.
-
-;; floor - (floor n) returns the greatest integer less than or equal to n.
-;; If n is an exact number, floor returns an integer,
-;; otherwise a double.
-;; ceil - (ceil n) returns the least integer greater than or equal to n.
-;; If n is an exact number, ceil returns an integer,
-;; otherwise a double.
-;; round - (round n) rounds to the nearest integer.
-;; round always returns an integer. round rounds up for values
-;; exactly in between two integers.
-
-
-;; sqrt - Implements the sqrt behavior I'm accustomed to from PLT Scheme,
-;; specifically, if the input is an exact number, and is a square
-;; of an exact number, the output will be exact. The downside
-;; is that for the common case (inexact square root), some extra
-;; computation is done to look for an exact square root first.
-;; So if you need blazingly fast square root performance, and you
-;; know you're just going to need a double result, you're better
-;; off calling java's Math/sqrt, or alternatively, you could just
-;; convert your input to a double before calling this sqrt function.
-;; If Clojure ever gets complex numbers, then this function will
-;; need to be updated (so negative inputs yield complex outputs).
-;; exact-integer-sqrt - Implements a math function from the R6RS Scheme
-;; standard. (exact-integer-sqrt k) where k is a non-negative integer,
-;; returns [s r] where k = s^2+r and k < (s+1)^2. In other words, it
-;; returns the floor of the square root and the "remainder".
-
-(ns
- #^{:author "Mark Engelberg",
- :doc "Math functions that deal intelligently with the various
-types in Clojure's numeric tower, as well as math functions
-commonly found in Scheme implementations.
-
-expt - (expt x y) is x to the yth power, returns an exact number
- if the base is an exact number, and the power is an integer,
- otherwise returns a double.
-abs - (abs n) is the absolute value of n
-gcd - (gcd m n) returns the greatest common divisor of m and n
-lcm - (lcm m n) returns the least common multiple of m and n
-
-The behavior of the next three functions on doubles is consistent
-with the behavior of the corresponding functions
-in Java's Math library, but on exact numbers, returns an integer.
-
-floor - (floor n) returns the greatest integer less than or equal to n.
- If n is an exact number, floor returns an integer,
- otherwise a double.
-ceil - (ceil n) returns the least integer greater than or equal to n.
- If n is an exact number, ceil returns an integer,
- otherwise a double.
-round - (round n) rounds to the nearest integer.
- round always returns an integer. round rounds up for values
- exactly in between two integers.
-
-
-sqrt - Implements the sqrt behavior I'm accustomed to from PLT Scheme,
- specifically, if the input is an exact number, and is a square
- of an exact number, the output will be exact. The downside
- is that for the common case (inexact square root), some extra
- computation is done to look for an exact square root first.
- So if you need blazingly fast square root performance, and you
- know you're just going to need a double result, you're better
- off calling java's Math/sqrt, or alternatively, you could just
- convert your input to a double before calling this sqrt function.
- If Clojure ever gets complex numbers, then this function will
- need to be updated (so negative inputs yield complex outputs).
-exact-integer-sqrt - Implements a math function from the R6RS Scheme
- standard. (exact-integer-sqrt k) where k is a non-negative integer,
- returns [s r] where k = s^2+r and k < (s+1)^2. In other words, it
- returns the floor of the square root and the "remainder".
-"}
- clojure.contrib.math)
-
-(derive ::integer ::exact)
-(derive java.lang.Integer ::integer)
-(derive java.math.BigInteger ::integer)
-(derive java.lang.Long ::integer)
-(derive java.math.BigDecimal ::exact)
-(derive clojure.lang.Ratio ::exact)
-(derive java.lang.Double ::inexact)
-(derive java.lang.Float ::inexact)
-
-(defmulti #^{:arglists '([base pow])
- :doc "(expt base pow) is base to the pow power.
-Returns an exact number if the base is an exact number and the power is an integer, otherwise returns a double."}
- expt (fn [x y] [(class x) (class y)]))
-
-(defn- expt-int [base pow]
- (loop [n pow, y 1, z base]
- (let [t (bit-and n 1), n (bit-shift-right n 1)]
- (cond
- (zero? t) (recur n y (* z z))
- (zero? n) (* z y)
- :else (recur n (* z y) (* z z))))))
-
-(defmethod expt [::exact ::integer] [base pow]
- (cond
- (pos? pow) (expt-int base pow)
- (zero? pow) 1
- :else (/ 1 (expt-int base (- pow)))))
-
-(defmethod expt :default [base pow] (Math/pow base pow))
-
-(defn abs "(abs n) is the absolute value of n" [n]
- (cond
- (not (number? n)) (throw (IllegalArgumentException.
- "abs requires a number"))
- (neg? n) (- n)
- :else n))
-
-(defmulti #^{:arglists '([n])
- :doc "(floor n) returns the greatest integer less than or equal to n.
-If n is an exact number, floor returns an integer, otherwise a double."}
- floor class)
-(defmethod floor ::integer [n] n)
-(defmethod floor java.math.BigDecimal [n] (.. n (setScale 0 BigDecimal/ROUND_FLOOR) (toBigInteger)))
-(defmethod floor clojure.lang.Ratio [n]
- (if (pos? n) (quot (. n numerator) (. n denominator))
- (dec (quot (. n numerator) (. n denominator)))))
-(defmethod floor :default [n]
- (Math/floor n))
-
-(defmulti #^{:arglists '([n])
- :doc "(ceil n) returns the least integer greater than or equal to n.
-If n is an exact number, ceil returns an integer, otherwise a double."}
- ceil class)
-(defmethod ceil ::integer [n] n)
-(defmethod ceil java.math.BigDecimal [n] (.. n (setScale 0 BigDecimal/ROUND_CEILING) (toBigInteger)))
-(defmethod ceil clojure.lang.Ratio [n]
- (if (pos? n) (inc (quot (. n numerator) (. n denominator)))
- (quot (. n numerator) (. n denominator))))
-(defmethod ceil :default [n]
- (Math/ceil n))
-
-(defmulti #^{:arglists '([n])
- :doc "(round n) rounds to the nearest integer.
-round always returns an integer. Rounds up for values exactly in between two integers."}
- round class)
-(defmethod round ::integer [n] n)
-(defmethod round java.math.BigDecimal [n] (floor (+ n 0.5M)))
-(defmethod round clojure.lang.Ratio [n] (floor (+ n 1/2)))
-(defmethod round :default [n] (Math/round n))
-
-(defn gcd "(gcd a b) returns the greatest common divisor of a and b" [a b]
- (if (or (not (integer? a)) (not (integer? b)))
- (throw (IllegalArgumentException. "gcd requires two integers"))
- (loop [a (abs a) b (abs b)]
- (if (zero? b) a,
- (recur b (mod a b))))))
-
-(defn lcm
- "(lcm a b) returns the least common multiple of a and b"
- [a b]
- (when (or (not (integer? a)) (not (integer? b)))
- (throw (IllegalArgumentException. "lcm requires two integers")))
- (cond (zero? a) 0
- (zero? b) 0
- :else (abs (* b (quot a (gcd a b))))))
-
-; Length of integer in binary, used as helper function for sqrt.
-(defmulti #^{:private true} integer-length class)
-(defmethod integer-length java.lang.Integer [n]
- (count (Integer/toBinaryString n)))
-(defmethod integer-length java.lang.Long [n]
- (count (Long/toBinaryString n)))
-(defmethod integer-length java.math.BigInteger [n]
- (count (. n toString 2)))
-
-;; Produces the largest integer less than or equal to the square root of n
-;; Input n must be a non-negative integer
-(defn- integer-sqrt [n]
- (cond
- (> n 24)
- (let [n-len (integer-length n)]
- (loop [init-value (if (even? n-len)
- (bit-shift-left 1 (bit-shift-right n-len 1))
- (bit-shift-left 2 (bit-shift-right n-len 1)))]
- (let [iterated-value (bit-shift-right (+ init-value (quot n init-value)) 1)]
- (if (>= iterated-value init-value)
- init-value
- (recur iterated-value)))))
- (> n 15) 4
- (> n 8) 3
- (> n 3) 2
- (> n 0) 1
- (> n -1) 0))
-
-(defn exact-integer-sqrt "(exact-integer-sqrt n) expects a non-negative integer n, and returns [s r] where n = s^2+r and n < (s+1)^2. In other words, it returns the floor of the square root and the 'remainder'.
-For example, (exact-integer-sqrt 15) is [3 6] because 15 = 3^2+6."
- [n]
- (if (or (not (integer? n)) (neg? n))
- (throw (IllegalArgumentException. "exact-integer-sqrt requires a non-negative integer"))
- (let [isqrt (integer-sqrt n),
- error (- n (* isqrt isqrt))]
- [isqrt error])))
-
-(defmulti #^{:arglists '([n])
- :doc "Square root, but returns exact number if possible."}
- sqrt class)
-(defmethod sqrt ::integer [n]
- (if (neg? n) Double/NaN
- (let [isqrt (integer-sqrt n),
- error (- n (* isqrt isqrt))]
- (if (zero? error) isqrt
- (Math/sqrt n)))))
-
-(defmethod sqrt clojure.lang.Ratio [n]
- (if (neg? n) Double/NaN
- (let [numerator (.numerator n),
- denominator (.denominator n),
- sqrtnum (sqrt numerator)]
- (if (float? sqrtnum)
- (Math/sqrt n)
- (let [sqrtden (sqrt denominator)]
- (if (float? sqrtnum)
- (Math/sqrt n)
- (/ sqrtnum sqrtden)))))))
-
-(defmethod sqrt java.math.BigDecimal [n]
- (if (neg? n) Double/NaN
- (let [frac (rationalize n),
- sqrtfrac (sqrt frac)]
- (if (ratio? sqrtfrac)
- (/ (BigDecimal. (.numerator sqrtfrac))
- (BigDecimal. (.denominator sqrtfrac)))
- sqrtfrac))))
-
-(defmethod sqrt :default [n]
- (Math/sqrt n))
diff --git a/src/clojure/contrib/math/tests.clj b/src/clojure/contrib/math/tests.clj deleted file mode 100644 index 0d434007..00000000 --- a/src/clojure/contrib/math/tests.clj +++ /dev/null @@ -1,118 +0,0 @@ -(ns clojure.contrib.math.tests
- (:use clojure.test
- clojure.contrib.math))
-
-(deftest test-expt
- (are [x y] (= x y) - (expt 2 3) 8
- (expt (expt 2 32) 2) (expt 2 64)
- (expt 4/3 2) 16/9
- (expt 2 -10) 1/1024
- (expt 0.5M 2) 0.25M
- (expt 5 4.2) (Math/pow 5 4.2)
- (expt 5.3 4) (Math/pow 5.3 4)))
-
-(deftest test-abs
- (are [x y] (= x y) - (abs -2) 2
- (abs 0) 0
- (abs 5) 5
- (abs 123456789123456789) 123456789123456789
- (abs -123456789123456789) 123456789123456789
- (abs 5/3) 5/3
- (abs -4/3) 4/3
- (abs 4.3M) 4.3M
- (abs -4.3M) 4.3M
- (abs 2.8) 2.8
- (abs -2.8) 2.8))
-
-(deftest test-gcd
- (are [x y] (= x y) - (gcd 4 3) 1
- (gcd 24 12) 12
- (gcd 24 27) 3
- (gcd 1 0) 1
- (gcd 0 1) 1
- (gcd 0 0) 0)
- (is (thrown? IllegalArgumentException (gcd nil 0)))
- (is (thrown? IllegalArgumentException (gcd 0 nil)))
- (is (thrown? IllegalArgumentException (gcd 7.0 0))))
-
-(deftest test-lcm
- (are [x y] (= x y) - (lcm 2 3) 6
- (lcm 3 2) 6
- (lcm -2 3) 6
- (lcm 2 -3) 6
- (lcm -2 -3) 6
- (lcm 4 10) 20
- (lcm 1 0) 0
- (lcm 0 1) 0
- (lcm 0 0))
- (is (thrown? IllegalArgumentException (lcm nil 0)))
- (is (thrown? IllegalArgumentException (lcm 0 nil)))
- (is (thrown? IllegalArgumentException (lcm 7.0 0))))
-
-(deftest test-floor
- (are [x y] (= x y) - (floor 6) 6
- (floor -6) -6
- (floor 123456789123456789) 123456789123456789
- (floor -123456789123456789) -123456789123456789
- (floor 4/3) 1
- (floor -4/3) -2
- (floor 4.3M) 4
- (floor -4.3M) -5
- (floor 4.3) 4.0
- (floor -4.3) -5.0))
-
-(deftest test-ceil
- (are [x y] (= x y) - (ceil 6) 6
- (ceil -6) -6
- (ceil 123456789123456789) 123456789123456789
- (ceil -123456789123456789) -123456789123456789
- (ceil 4/3) 2
- (ceil -4/3) -1
- (ceil 4.3M) 5
- (ceil -4.3M) -4
- (ceil 4.3) 5.0
- (ceil -4.3) -4.0))
-
-(deftest test-round
- (are [x y] (= x y) - (round 6) 6
- (round -6) -6
- (round 123456789123456789) 123456789123456789
- (round -123456789123456789) -123456789123456789
- (round 4/3) 1
- (round 5/3) 2
- (round 5/2) 3
- (round -4/3) -1
- (round -5/3) -2
- (round -5/2) -2
- (round 4.3M) 4
- (round 4.7M) 5
- (round -4.3M) -4
- (round -4.7M) -5
- (round 4.5M) 5
- (round -4.5M) -4
- (round 4.3) 4
- (round 4.7) 5
- (round -4.3) -4
- (round -4.7) -5
- (round 4.5) 5
- (round -4.5) -4))
-
-(deftest test-sqrt
- (are [x y] (= x y) - (sqrt 9) 3
- (sqrt 16/9) 4/3
- (sqrt 0.25M) 0.5M
- (sqrt 2) (Math/sqrt 2)))
-
-(deftest test-exact-integer-sqrt
- (are [x y] (= x y) - (exact-integer-sqrt 15) [3 6]
- (exact-integer-sqrt (inc (expt 2 64))) [(expt 2 32) 1]
- (exact-integer-sqrt 1000000000000) [1000000 0]))
diff --git a/src/clojure/contrib/miglayout.clj b/src/clojure/contrib/miglayout.clj deleted file mode 100644 index 67aced84..00000000 --- a/src/clojure/contrib/miglayout.clj +++ /dev/null @@ -1,79 +0,0 @@ -;; Copyright (c) Stephen C. Gilardi. 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. -;; -;; clojure.contrib.miglayout -;; -;; Clojure support for the MiGLayout layout manager -;; http://www.miglayout.com/ -;; -;; Example: -;; -;; (use '[clojure.contrib.miglayout.test :as mlt :only ()]) -;; (dotimes [i 5] (mlt/run-test i)) -;; -;; scgilardi (gmail) -;; Created 5 October 2008 - -(ns - #^{:author "Stephen C. Gilardi", - :doc "Clojure support for the MiGLayout layout manager -http://www.miglayout.com/ - -Example: - - (use '[clojure.contrib.miglayout.test :as mlt :only ()]) - (dotimes [i 5] (mlt/run-test i)) - -"} - clojure.contrib.miglayout - (:import javax.swing.JComponent) - (:use clojure.contrib.miglayout.internal)) - -(defn miglayout - "Adds java.awt.Components to a javax.swing.JComponent with constraints - formatted for the MiGLayout layout manager. - - Arguments: container [item constraint*]* - - - container: the container for the specified components, its layout - manager will be set to a new instance of MigLayout - - - an inline series of items and constraints--each item may be followed - by zero or more constraints. - - Item: - - - An item is either a Component or one of the keywords :layout - :column or :row. Constraints for a keyword item affect the entire - layout. - - Constraint: string, keyword, vector, map, or set - - - A string specifies one or more constraints each with zero or more - arguments. - - A keyword specifies a single constraint without arguments - - A vector specifies a single constraint with one or more arguments - - A map specifies one or more constraints as keys, each mapped to a - single argument - - A set groups two or more constraints, each a string, keyword, - vector, map, or set - - Any items marked with an \"id\" constraint will be included in a map from - id to component attached to the container. The map can be retrieved using - clojure.contrib.miglayout/components." - [#^JComponent container & args] - (let [item-constraints (apply parse-item-constraints args) - {:keys [keywords components]} item-constraints - {:keys [layout column row]} keywords] - (do-layout container layout column row components))) - -(defn components - "Returns a map from id (a keyword) to component for all components with - an id constraint set" - [#^JComponent container] - (get-components container)) diff --git a/src/clojure/contrib/miglayout/example.clj b/src/clojure/contrib/miglayout/example.clj deleted file mode 100644 index c688e9fe..00000000 --- a/src/clojure/contrib/miglayout/example.clj +++ /dev/null @@ -1,60 +0,0 @@ -;; Copyright (c) Stephen C. Gilardi. 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. -;; -;; clojure.contrib.miglayout.example -;; -;; A temperature converter using miglayout. Demonstrates accessing -;; components by their id constraint. -;; -;; scgilardi (gmail) -;; Created 31 May 2009 - -(ns clojure.contrib.miglayout.example - (:import (javax.swing JButton JFrame JLabel JPanel JTextField - SwingUtilities)) - (:use (clojure.contrib - [miglayout :only (miglayout components)] - [swing-utils :only (add-key-typed-listener)]))) - -(defn fahrenheit - "Converts a Celsius temperature to Fahrenheit. Input and output are - strings. Returns \"input?\" if the input can't be parsed as a Double." - [celsius] - (try - (format "%.2f" (+ 32 (* 1.8 (Double/parseDouble celsius)))) - (catch NumberFormatException _ "input?"))) - -(defn- handle-key - "Clears output on most keys, shows conversion on \"Enter\"" - [event out] - (.setText out - (if (= (.getKeyChar event) \newline) - (fahrenheit (-> event .getComponent .getText)) - ""))) - -(defn converter-ui - "Lays out and shows a Temperature Converter UI" - [] - (let [panel - (miglayout (JPanel.) - (JTextField. 6) {:id :input} - (JLabel. "\u00b0Celsius") :wrap - (JLabel.) {:id :output} - (JLabel. "\u00b0Fahrenheit")) - {:keys [input output]} (components panel)] - (add-key-typed-listener input handle-key output) - (doto (JFrame. "Temperature Converter") - (.setDefaultCloseOperation JFrame/DISPOSE_ON_CLOSE) - (.add panel) - (.pack) - (.setVisible true)))) - -(defn main - "Invokes converter-ui in the AWT Event thread" - [] - (SwingUtilities/invokeLater converter-ui)) diff --git a/src/clojure/contrib/miglayout/internal.clj b/src/clojure/contrib/miglayout/internal.clj deleted file mode 100644 index e06bd2e0..00000000 --- a/src/clojure/contrib/miglayout/internal.clj +++ /dev/null @@ -1,120 +0,0 @@ -;; Copyright (c) Stephen C. Gilardi. 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. -;; -;; clojure.contrib.miglayout.internal -;; -;; Internal functions for 'clojure.contrib.miglayout -;; -;; scgilardi (gmail) -;; Created 13 October 2008 - -(ns clojure.contrib.miglayout.internal - (:import (clojure.lang RT Reflector) - java.awt.Component - javax.swing.JComponent) - (:use (clojure.contrib - [core :only (new-by-name)] - [except :only (throwf)] - [fcase :only (fcase)] - [java-utils :only (as-str)]))) - -(def MigLayout "net.miginfocom.swing.MigLayout") -(def LayoutCallback "net.miginfocom.layout.LayoutCallback") -(def ConstraintParser "net.miginfocom.layout.ConstraintParser") - -(declare format-constraints) - -(defn format-constraint - "Returns a vector of vectors representing one or more constraints - separated by commas. Constraints may be specified in Clojure using - strings, keywords, vectors, maps, and/or sets." - [c] - [[", "] - (fcase #(%1 %2) c - string? [c] - keyword? [c] - vector? (interpose " " c) - map? (apply concat (interpose [", "] (map #(interpose " " %) c))) - set? (apply concat (interpose [", "] (map format-constraints c))) - (throwf IllegalArgumentException - "unrecognized constraint: %s (%s)" c (class c)))]) - -(defn format-constraints - "Returns a string representing all the constraints for one keyword-item - or component formatted for miglayout." - [& constraints] - (let [formatted - (apply str - (map as-str - (rest (reduce concat [] - (mapcat format-constraint constraints)))))] -;; (prn formatted) - formatted)) - -(defn component? - "Returns true if x is a java.awt.Component" - [x] - (instance? Component x)) - -(defn constraint? - "Returns true if x is not a keyword-item or component" - [x] - (not - (or (component? x) - (#{:layout :column :row} x)))) - -(defn parse-item-constraints - "Iterates over args and builds a map containing values associated with - :keywords and :components. The value for :keywords is a map from keyword - items to constraints strings. The value for :components is a vector of - vectors each associating a component with its constraints string." - [& args] - (loop [[item & args] args - item-constraints {:keywords {} :components []}] - (if item - (let [[constraints args] (split-with constraint? args)] - (recur args - (update-in - item-constraints - [(if (component? item) :components :keywords)] - conj [item (apply format-constraints constraints)]))) - item-constraints))) - -(defn parse-component-constraint - "Parses a component constraint string returning a CC object" - [constraint] - (Reflector/invokeStaticMethod - ConstraintParser "parseComponentConstraint" (into-array [constraint]))) - -(defn add-components - "Adds components with constraints to a container" - [#^JComponent container components] - (loop [[[#^Component component constraint] & components] components - id-map nil] - (if component - (let [cc (parse-component-constraint constraint)] - (.add container component cc) - (recur - components - (if-let [id (.getId cc)] - (assoc id-map (keyword id) component) - id-map))) - (doto container (.putClientProperty ::components id-map))))) - -(defn get-components - "Returns a map from id to component for all components with an id" - [#^JComponent container] - (.getClientProperty container ::components)) - -(defn do-layout - "Attaches a MigLayout layout manager to container and adds components - with constraints" - [#^JComponent container layout column row components] - (doto container - (.setLayout (new-by-name MigLayout layout column row)) - (add-components components))) diff --git a/src/clojure/contrib/miglayout/test.clj b/src/clojure/contrib/miglayout/test.clj deleted file mode 100644 index dec12ba8..00000000 --- a/src/clojure/contrib/miglayout/test.clj +++ /dev/null @@ -1,145 +0,0 @@ -;; Copyright (c) Stephen C. Gilardi. 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. -;; -;; clojure.contrib.miglayout.test -;; -;; Test/example for clojure.contrib.miglayout -;; -;; scgilardi (gmail) -;; Created 5 October 2008 - -(ns clojure.contrib.miglayout.test - (:import (javax.swing JButton JFrame JLabel JList JPanel - JScrollPane JTabbedPane JTextField JSeparator)) - (:use clojure.contrib.miglayout)) - -(def tests) - -(defn run-test - [index] - (let [panel ((tests index) (JPanel.))] - (println index (components panel)) - (doto (JFrame. (format "MigLayout Test %d" index)) - (.add panel) - (.pack) - (.setVisible true)))) - -(defn label - "Returns a swing label" - [text] - (JLabel. text)) - -(defn text-field - "Returns a swing text field" - ([] (text-field 10)) - ([width] - (JTextField. width))) - -(defn sep - "Returns a swing separator" - [] - (JSeparator.)) - -(def tests [ - - (fn test0 - [panel] - (miglayout panel - (label "Hello") - (label "World") {:gap :unrelated} - (text-field) :wrap - (label "Bonus!") - (JButton. "Bang it") {:wmin :button :grow :x :span 2} :center)) - - ;; test1 and test2 are based on code from - ;; http://www.devx.com/java/Article/38017/1954 - - ;; constraints as strings exclusively - (fn test1 - [panel] - (miglayout panel - :column "[right]" - (label "General") "split, span" - (sep) "growx, wrap" - (label "Company") "gap 10" - (text-field "") "span, growx" - (label "Contact") "gap 10" - (text-field "") "span, growx, wrap" - (label "Propeller") "split, span, gaptop 10" - (sep) "growx, wrap, gaptop 10" - (label "PTI/kW") "gapx 10, gapy 15" - (text-field) - (label "Power/kW") "gap 10" - (text-field) "wrap" - (label "R/mm") "gap 10" - (text-field) - (label "D/mm") "gap 10" - (text-field))) - - ;; the same constraints as strings, keywords, vectors, and maps - (fn test2 - [panel] - (miglayout panel - :column "[right]" - (label "General") "split, span" - (sep) :growx :wrap - (label "Company") [:gap 10] - (text-field "") :span :growx - (label "Contact") [:gap 10] - (text-field "") :span :growx :wrap - (label "Propeller") :split :span [:gaptop 10] - (sep) :growx :wrap [:gaptop 10] - (label "PTI/kW") {:gapx 10 :gapy 15} - (text-field) - (label "Power/kW") [:gap 10] - (text-field) :wrap - (label "R/mm") [:gap 10] - (text-field) - (label "D/mm") [:gap 10] - (text-field))) - - ;; the same constraints using symbols to name groups of constraints - (fn test3 - [panel] - (let [g [:gap 10] - gt [:gaptop 10] - gxs #{:growx :span} - gxw #{:growx :wrap} - gxy {:gapx 10 :gapy 15} - right "[right]" - ss #{:split :span} - w :wrap] - (miglayout panel - :column right - (label "General") ss - (sep) gxw - (label "Company") g - (text-field "") gxs - (label "Contact") g - (text-field "") gxs - (label "Propeller") ss gt - (sep) gxw g - (label "PTI/kW") gxy - (text-field) - (label "Power/kW") g - (text-field) w - (label "R/mm") g - (text-field) - (label "D/mm") g - (text-field)))) - - (fn test4 - [panel] - (miglayout panel - (label "First Name") - (text-field) {:id :firstname} - (label "Surname") [:gap :unrelated] - (text-field) {:id :surname} :wrap - (label "Address") - (text-field) {:id :address} :span :grow)) -]) diff --git a/src/clojure/contrib/mmap.clj b/src/clojure/contrib/mmap.clj deleted file mode 100644 index 341c27e3..00000000 --- a/src/clojure/contrib/mmap.clj +++ /dev/null @@ -1,90 +0,0 @@ -; Copyright (c) Chris Houser, April 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. - -; Functions for memory-mapping files, plus some functions that use a -; mmaped file for "normal" activies -- slurp, load-file, etc. - -(ns - #^{:author "Chris Houser", - :doc "Functions for memory-mapping files, plus some functions that use a -mmaped file for \"normal\" activies -- slurp, load-file, etc."} - clojure.contrib.mmap - (:refer-clojure :exclude (slurp load-file)) - (:import (java.nio ByteBuffer CharBuffer) - (java.io PushbackReader InputStream InputStreamReader - FileInputStream))) - -;(set! *warn-on-reflection* true) - -(def READ_ONLY #^{:private true} - (java.nio.channels.FileChannel$MapMode/READ_ONLY)) - -(defn mmap - "Memory-map the file named f. Returns a ByteBuffer." - [f] - (let [channel (.getChannel (FileInputStream. f))] - (.map channel READ_ONLY 0 (.size channel)))) - -(defn slurp - "Reads the file named by f and returns it as a string." - [#^String f] - (.. java.nio.charset.Charset (forName "UTF-8") - (newDecoder) (decode (mmap f)))) - -(defn buffer-stream - "Returns an InputStream for a ByteBuffer, such as returned by mmap." - [#^ByteBuffer buf] - (proxy [InputStream] [] - (available [] (.remaining buf)) - (read - ([] (if (.hasRemaining buf) (.get buf) -1)) - ([dst offset len] (let [actlen (min (.remaining buf) len)] - (.get buf dst offset actlen) - (if (< actlen 1) -1 actlen)))))) - -(defn load-file [f] - "Like clojure.lang/load-file, but uses mmap internally." - (with-open [rdr (-> f mmap buffer-stream InputStreamReader. PushbackReader.)] - (load-reader rdr))) - - -(comment - -(alias 'mmap 'clojure.contrib.mmap) -(alias 'core 'clojure.core) - -;--- -; zip_filter.clj is 95KB -(def tf "/home/chouser/build/clojure/src/clj/clojure/core.clj") -(println "\nload-file" tf) -(time (dotimes [_ 5] (core/load-file tf))) ; 5420.177813 msecs -(time (dotimes [_ 5] (mmap/load-file tf))) ; 7946.854434 msecs -- not so good - -;--- -; kern.log.0 is 961KB -(def tf "/var/log/kern.log.0") -(println "\nslurp" tf) -(time (dotimes [_ 10] (.length (core/slurp tf)))) ; 435.767226 msecs -(time (dotimes [_ 10] (.length (mmap/slurp tf)))) ; 93.176858 msecs - -;--- -; kern.log.0 is 961KB -(def tf "/var/log/kern.log.0") -(println "\nregex slurp large" tf) -(time (dotimes [_ 10] (count (re-seq #"EXT3.*" (core/slurp tf))))) ; 416 -(time (dotimes [_ 10] (count (re-seq #"EXT3.*" (mmap/slurp tf))))) ; 101 - -;--- -; mmap.clj is about 3.1KB -(def tf "/home/chouser/proj/clojure-contrib/src/clojure/contrib/mmap.clj") -(println "\nregex slurp small" tf) - -(time (dotimes [_ 1000] (count (re-seq #"defn \S*" (core/slurp tf))))) ; 308 -(time (dotimes [_ 1000] (count (re-seq #"defn \S*" (mmap/slurp tf))))) ; 198 - -) diff --git a/src/clojure/contrib/mock.clj b/src/clojure/contrib/mock.clj deleted file mode 100644 index a284b527..00000000 --- a/src/clojure/contrib/mock.clj +++ /dev/null @@ -1,285 +0,0 @@ -;;; clojure.contrib.mock.clj: mocking/expectation framework for Clojure
-
-;; by Matt Clark
-
-;; Copyright (c) Matt Clark, 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).
-;; 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.
-;;------------------------------------------------------------------------------
-
-(comment
- ;; This is a simple function mocking library I accidentally wrote as a side
- ;; effect of trying to write an opengl library in clojure. This is loosely
- ;; based on various ruby and java mocking frameworks I have used in the past
- ;; such as mockito, easymock, and whatever rspec uses.
- ;;
- ;; expect uses bindings to wrap the functions that are being tested and
- ;; then validates the invocation count at the end. The expect macro is the
- ;; main entry point and it is given a vector of binding pairs.
- ;; The first of each pair names the dependent function you want to override,
- ;; while the second is a hashmap containing the mock description, usually
- ;; created via the simple helper methods described below.
- ;;
- ;; Usage:
- ;;
- ;; there are one or more dependent functions:
-
- (defn dep-fn1 [] "time consuming calculation in 3rd party library")
- (defn dep-fn2 [x] "function with undesirable side effects while testing")
-
- ;; then we have the code under test that calls these other functions:
-
- (defn my-code-under-test [] (dep-fn1) (dep-fn2 "a") (+ 2 2))
-
- ;; to test this code, we simply surround it with an expect macro within
- ;; the test:
-
- (expect [dep-fn1 (times 1)
- dep-fn2 (times 1 (has-args [#(= "a" %)]))]
- (my-code-under-test))
-
- ;; When an expectation fails during execution of the function under test,
- ;; an error condition function is called with the name of the function
- ;; being mocked, the expected form and the actual value. These
- ;; error functions can be overridden to allow easy integration into
- ;; test frameworks such as test-is by reporting errors in the function
- ;; overrides.
-
- ) ;; end comment
-
-(ns clojure.contrib.mock
- #^{:author "Matt Clark",
- :doc "function mocking/expectations for Clojure" }
- (:use [clojure.contrib.seq-utils :only (positions)]
- [clojure.contrib.def :only (defmacro-)]))
-
-
-;;------------------------------------------------------------------------------
-;; These are the error condition functions. Override them to integrate into
-;; the test framework of your choice, or to simply customize error handling.
-
-(defn report-problem
- {:dynamic true}
- ([function expected actual]
- (report-problem function expected actual "Expectation not met."))
- ([function expected actual message]
- (prn (str message " Function name: " function
- " expected: " expected " actual: " actual))))
-
-(defn no-matching-function-signature
- {:dynamic true}
- [function expected actual]
- (report-problem function expected actual
- "No matching real function signature for given argument count."))
-
-(defn unexpected-args
- {:dynamic true}
- [function expected actual i]
- (report-problem function expected actual
- (str "Argument " i " has an unexpected value for function.")))
-
-(defn incorrect-invocation-count
- {:dynamic true}
- [function expected actual]
- (report-problem function expected actual "Unexpected invocation count."))
-
-
-;;------------------------------------------------------------------------------
-;; Internal Functions - ignore these
-
-
-(defn- has-arg-count-match?
- "Given the sequence of accepted argument vectors for a function,
-returns true if at least one matches the given-count value."
- [arg-lists given-count]
- (some #(let [[ind] (positions #{'&} %)]
- (if ind
- (>= given-count ind)
- (= (count %) given-count)))
- arg-lists))
-
-
-(defn has-matching-signature?
- "Calls no-matching-function-signature if no match is found for the given
-function. If no argslist meta data is available for the function, it is
-not called."
- [fn-name args]
- (let [arg-count (count args)
- arg-lists (:arglists (meta (resolve fn-name)))]
- (if (and arg-lists (not (has-arg-count-match? arg-lists arg-count)))
- (no-matching-function-signature fn-name arg-lists args))))
-
-
-(defn make-arg-checker
- "Creates the argument verifying function for a replaced dependency within
-the expectation bound scope. These functions take the additional argument
-of the name of the replaced function, then the rest of their args. It is
-designed to be called from the mock function generated in the first argument
-of the mock info object created by make-mock."
- [arg-preds arg-pred-forms]
- (let [sanitized-preds (map (fn [v] (if (fn? v) v #(= v %))) arg-preds)]
- (fn [fn-name & args]
- (every? true?
- (map (fn [pred arg pred-form i] (if (pred arg) true
- (unexpected-args fn-name pred-form arg i)))
- sanitized-preds args arg-pred-forms (iterate inc 0))))))
-
-
-(defn make-count-checker
- "creates the count checker that is invoked at the end of an expectation, after
-the code under test has all been executed. The function returned takes the
-name of the associated dependency and the invocation count as arguments."
- [pred pred-form]
- (let [pred-fn (if (integer? pred) #(= pred %) pred)]
- (fn [fn-name v] (if (pred-fn v) true
- (incorrect-invocation-count fn-name pred-form v)))))
-
-; Borrowed from clojure core. Remove if this ever becomes public there.
-(defmacro- assert-args
- [fnname & pairs]
- `(do (when-not ~(first pairs)
- (throw (IllegalArgumentException.
- ~(str fnname " requires " (second pairs)))))
- ~(let [more (nnext pairs)]
- (when more
- (list* `assert-args fnname more)))))
-
-(defn make-mock
- "creates a vector containing the following information for the named function:
-1. dependent function replacement - verifies signature, calls arg checker,
-increases count, returns return value.
-2. an atom containing the invocation count
-3. the invocation count checker function
-4. a symbol of the name of the function being replaced."
- [fn-name expectation-hash]
- (assert-args make-mock
- (map? expectation-hash) "a map of expectations")
- (let [arg-checker (or (expectation-hash :has-args) (fn [& args] true))
- count-atom (atom 0)
- ret-fn (or
- (expectation-hash :calls)
- (fn [& args] (expectation-hash :returns)))]
- [(fn [& args]
- (has-matching-signature? fn-name args)
- (apply arg-checker fn-name args)
- (swap! count-atom inc)
- (apply ret-fn args))
- count-atom
- (or (expectation-hash :times) (fn [fn-name v] true))
- fn-name]))
-
-
-(defn validate-counts
- "given the sequence of all mock data for the expectation, simply calls the
-count checker for each dependency."
- [mock-data] (doseq [[mfn i checker fn-name] mock-data] (checker fn-name @i)))
-
-(defn #^{:private true} make-bindings [expect-bindings mock-data-sym]
- `[~@(interleave (map #(first %) (partition 2 expect-bindings))
- (map (fn [i] `(nth (nth ~mock-data-sym ~i) 0))
- (range (quot (count expect-bindings) 2))))])
-
-
-;;------------------------------------------------------------------------------
-;; These are convenience functions to improve the readability and use of this
-;; library. Useful in expressions such as:
-;; (expect [dep-fn1 (times (more-than 1) (returns 15)) etc)
-
-(defn once [x] (= 1 x))
-
-(defn never [x] (zero? x))
-
-(defn more-than [x] #(< x %))
-
-(defn less-than [x] #(> x %))
-
-(defn between [x y] #(and (< x %) (> y %)))
-
-
-;;------------------------------------------------------------------------------
-;; The following functions can be used to build up the expectation hash.
-
-(defn returns
- "Creates or associates to an existing expectation hash the :returns key with
-a value to be returned by the expectation after a successful invocation
-matching its expected arguments (if applicable).
-Usage:
-(returns ret-value expectation-hash?)"
-
- ([val] (returns val {}))
- ([val expectation-hash] (assoc expectation-hash :returns val)))
-
-
-(defn calls
- "Creates or associates to an existing expectation hash the :calls key with a
-function that will be called with the given arguments. The return value from
-this function will be returned returned by the expected function. If both this
-and returns are specified, the return value of \"calls\" will have precedence.
-Usage:
-(calls some-fn expectation-hash?)"
-
- ([val] (calls val {}))
- ([val expectation-hash] (assoc expectation-hash :calls val)))
-
-
-(defmacro has-args
- "Creates or associates to an existing expectation hash the :has-args key with
-a value corresponding to a function that will either return true if its
-argument expectations are met or throw an exception with the details of the
-first failed argument it encounters.
-Only specify as many predicates as you are interested in verifying. The rest
-of the values are safely ignored.
-Usage:
-(has-args [arg-pred-1 arg-pred-2 ... arg-pred-n] expectation-hash?)"
-
- ([arg-pred-forms] `(has-args ~arg-pred-forms {}))
- ([arg-pred-forms expect-hash-form]
- (assert-args has-args
- (vector? arg-pred-forms) "a vector of argument predicates")
- `(assoc ~expect-hash-form :has-args
- (make-arg-checker ~arg-pred-forms '~arg-pred-forms))))
-
-
-(defmacro times
- "Creates or associates to an existing expectation hash the :times key with a
-value corresponding to a predicate function which expects an integer value.
-This function can either be specified as the first argument to times or can be
-the result of calling times with an integer argument, in which case the
-predicate will default to being an exact match. This predicate is called at
-the end of an expect expression to validate that an expected dependency
-function was called the expected number of times.
-Usage:
-(times n)
-(times #(> n %))
-(times n expectation-hash)"
- ([times-fn] `(times ~times-fn {}))
- ([times-fn expectation-hash]
- `(assoc ~expectation-hash :times (make-count-checker ~times-fn '~times-fn))))
-
-
-;-------------------------------------------------------------------------------
-; The main expect macro.
-(defmacro expect
- "Use expect to redirect calls to dependent functions that are made within the
-code under test. Instead of calling the functions that would normally be used,
-temporary stubs are used, which can verify function parameters and call counts.
-Return values can also be specified as needed.
-Usage:
-(expect [dep-fn (has-args [arg-pred1] (times n (returns x)))]
- (function-under-test a b c))"
-
- [expect-bindings & body]
- (assert-args expect
- (vector? expect-bindings) "a vector of expectation bindings"
- (even? (count expect-bindings))
- "an even number of forms in expectation bindings")
- (let [mock-data (gensym "mock-data_")]
- `(let [~mock-data (map (fn [args#]
- (apply clojure.contrib.mock/make-mock args#))
- ~(cons 'list (map (fn [[n m]] (vector (list 'quote n) m))
- (partition 2 expect-bindings))))]
- (binding ~(make-bindings expect-bindings mock-data) ~@body)
- (clojure.contrib.mock/validate-counts ~mock-data) true)))
diff --git a/src/clojure/contrib/mock/test_adapter.clj b/src/clojure/contrib/mock/test_adapter.clj deleted file mode 100644 index 466cb537..00000000 --- a/src/clojure/contrib/mock/test_adapter.clj +++ /dev/null @@ -1,38 +0,0 @@ -;;; test_adapter.clj: clojure.test adapter for mocking/expectation framework for Clojure - -;; by Matt Clark - -;; Copyright (c) Matt Clark, 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). -;; 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. - -(ns clojure.contrib.mock.test-adapter - (:require [clojure.contrib.mock :as mock]) - (:use clojure.test - clojure.contrib.ns-utils)) - -(immigrate 'clojure.contrib.mock) - -(defn report-problem - "This function is designed to be used in a binding macro to override -the report-problem function in clojure.contrib.mock. Instead of printing -the error to the console, the error is logged via clojure.test." - {:dynamic true} - [fn-name expected actual msg] - (report {:type :fail, - :message (str msg " Function name: " fn-name), - :expected expected, - :actual actual})) - - -(defmacro expect [& body] - "Use this macro instead of the standard c.c.mock expect macro to have -failures reported through clojure.test." - `(binding [mock/report-problem report-problem] - (mock/expect ~@body))) - - - diff --git a/src/clojure/contrib/monadic_io_streams.clj b/src/clojure/contrib/monadic_io_streams.clj deleted file mode 100644 index 28772283..00000000 --- a/src/clojure/contrib/monadic_io_streams.clj +++ /dev/null @@ -1,145 +0,0 @@ -;; Monadic I/O - -;; by Konrad Hinsen -;; last updated June 24, 2009 - -;; Copyright (c) Konrad Hinsen, 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. - -(ns - #^{:author "Konrad Hinsen" - :doc "Monadic I/O with Java input/output streams - Defines monadic I/O statements to be used in a state monad - with an input or output stream as the state. The macro - monadic-io creates a stream, runs a monadic I/O statement - on it, and closes the stream. This structure permits the - definition of purely functional compound I/O statements - which are applied to streams that can never escape from the - monadic statement sequence."} - clojure.contrib.monadic-io-streams - (:refer-clojure :exclude (read-line print println flush)) - (:use [clojure.contrib.monads - :only (with-monad domonad state-m state-m-until)]) - (:use [clojure.contrib.generic.functor :only (fmap)]) - (:use [clojure.contrib.duck-streams :only (reader writer)])) - -; -; Wrap the state into a closure to make sure that "evil" code -; can't obtain the stream using fetch-state and manipulate it. -; -(let [key (Object.) - lock (fn [state] (fn [x] (if (identical? x key) state nil))) - unlock (fn [state] (state key))] - - ; - ; Basic stream I/O statements as provided by Java - ; - (defn read-char - "Read a single character" - [] - (fn [s] [(.read (unlock s)) s])) - - (defn read-line - "Read a single line" - [] - (fn [s] [(.readLine (unlock s)) s])) - - (defn skip-chars - "Skip n characters" - [n] - (fn [s] [(.skip (unlock s) n) s])) - - (defn write - "Write text (a string)" - [#^String text] - (fn [s] [(.write (unlock s) text) s])) - - (defn flush - "Flush" - [] - (fn [s] [(.flush (unlock s)) s])) - - (defn print - "Print obj" - [obj] - (fn [s] [(.print (unlock s) obj) s])) - - (defn println - "Print obj followed by a newline" - ([] - (fn [s] [(.println (unlock s)) s])) - ([obj] - (fn [s] [(.println (unlock s) obj) s]))) - - ; - ; Inject I/O streams into monadic I/O statements - ; - (defn with-reader - "Create a reader from reader-spec, run the monadic I/O statement - on it, and close the reader. reader-spec can be any object accepted - by clojure.contrib.duck-streams/reader." - [reader-spec statement] - (with-open [r (reader reader-spec)] - (first (statement (lock r))))) - - (defn with-writer - "Create a writer from writer-spec, run the monadic I/O statement - on it, and close the writer. writer-spec can be any object accepted - by clojure.contrib.duck-streams/writer." - [writer-spec statement] - (with-open [w (writer writer-spec)] - (first (statement (lock w))))) - - (defn with-io-streams - "Open one or more streams as specified by io-spec, run a monadic - I/O statement on them, and close the streams. io-spec is - a binding-like vector in which each stream is specified by - three element: a keyword by which the stream can be referred to, - the stream mode (:read or :write), and a stream specification as - accepted by clojure.contrib.duck-streams/reader (mode :read) or - clojure.contrib.duck-streams/writer (mode :write). The statement - is run on a state which is a map from keywords to corresponding - streams. Single-stream monadic I/O statements must be wrapped - with clojure.contrib.monads/with-state-field." - [io-specs statement] - (letfn [(run-io [io-specs state statement] - (if (zero? (count io-specs)) - (first (statement state)) - (let [[[key mode stream-spec] & r] io-specs - opener (cond (= mode :read) reader - (= mode :write) writer - :else (throw - (Exception. - "Mode must be :read or :write")))] - (with-open [stream (opener stream-spec)] - (run-io r (assoc state key (lock stream)) statement)))))] - (run-io (partition 3 io-specs) {} statement)))) - -; -; Compound I/O statements -; -(with-monad state-m - - (defn- add-line - "Read one line and add it to the end of the vector lines. Return - [lines eof], where eof is an end-of-file flag. The input eof argument - is not used." - [[lines eof]] - (domonad - [line (read-line)] - (if (nil? line) - [lines true] - [(conj lines line) false]))) - - (defn read-lines - "Read all lines and return them in a vector" - [] - (domonad - [[lines eof] (state-m-until second add-line [[] false])] - lines))) - diff --git a/src/clojure/contrib/monads.clj b/src/clojure/contrib/monads.clj deleted file mode 100644 index 8d287105..00000000 --- a/src/clojure/contrib/monads.clj +++ /dev/null @@ -1,580 +0,0 @@ -;; Monads in Clojure - -;; by Konrad Hinsen -;; last updated June 30, 2009 - -;; Copyright (c) Konrad Hinsen, 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. - -(ns - #^{:author "Konrad Hinsen" - :see-also [["http://onclojure.com/2009/03/05/a-monad-tutorial-for-clojure-programmers-part-1/" "Monad tutorial part 1"] - ["http://onclojure.com/2009/03/06/a-monad-tutorial-for-clojure-programmers-part-2/" "Monad tutorial part 2"] - ["http://onclojure.com/2009/03/23/a-monad-tutorial-for-clojure-programmers-part-3/" "Monad tutorial part 3"] - ["http://onclojure.com/2009/04/24/a-monad-tutorial-for-clojure-programmers-part-4/" "Monad tutorial part 4"] - ["http://intensivesystems.net/tutorials/monads_101.html" "Monads in Clojure part 1"] - ["http://intensivesystems.net/tutorials/monads_201.html" "Monads in Clojure part 2"]] - :doc "This library contains the most commonly used monads as well - as macros for defining and using monads and useful monadic - functions."} - clojure.contrib.monads - (:require [clojure.contrib.accumulators]) - (:use [clojure.contrib.macro-utils :only (with-symbol-macros defsymbolmacro)]) - (:use [clojure.contrib.def :only (name-with-attributes)])) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; Defining monads -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defmacro monad - "Define a monad by defining the monad operations. The definitions - are written like bindings to the monad operations m-bind and - m-result (required) and m-zero and m-plus (optional)." - [operations] - `(let [~'m-bind ::undefined - ~'m-result ::undefined - ~'m-zero ::undefined - ~'m-plus ::undefined - ~@operations] - {:m-result ~'m-result - :m-bind ~'m-bind - :m-zero ~'m-zero - :m-plus ~'m-plus})) - -(defmacro defmonad - "Define a named monad by defining the monad operations. The definitions - are written like bindings to the monad operations m-bind and - m-result (required) and m-zero and m-plus (optional)." - - ([name doc-string operations] - (let [doc-name (with-meta name {:doc doc-string})] - `(defmonad ~doc-name ~operations))) - - ([name operations] - `(def ~name (monad ~operations)))) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; Using monads -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defn- add-monad-step - "Add a monad comprehension step before the already transformed - monad comprehension expression mexpr." - [mexpr step] - (let [[bform expr] step] - (cond (identical? bform :when) `(if ~expr ~mexpr ~'m-zero) - (identical? bform :let) `(let ~expr ~mexpr) - :else (list 'm-bind expr (list 'fn [bform] mexpr))))) - -(defn- monad-expr - "Transforms a monad comprehension, consisting of a list of steps - and an expression defining the final value, into an expression - chaining together the steps using :bind and returning the final value - using :result. The steps are given as a vector of - binding-variable/monadic-expression pairs." - [steps expr] - (when (odd? (count steps)) - (throw (Exception. "Odd number of elements in monad comprehension steps"))) - (let [rsteps (reverse (partition 2 steps)) - [lr ls] (first rsteps)] - (if (= lr expr) - ; Optimization: if the result expression is equal to the result - ; of the last computation step, we can eliminate an m-bind to - ; m-result. - (reduce add-monad-step - ls - (rest rsteps)) - ; The general case. - (reduce add-monad-step - (list 'm-result expr) - rsteps)))) - -(defmacro with-monad - "Evaluates an expression after replacing the keywords defining the - monad operations by the functions associated with these keywords - in the monad definition given by name." - [monad & exprs] - `(let [name# ~monad - ~'m-bind (:m-bind name#) - ~'m-result (:m-result name#) - ~'m-zero (:m-zero name#) - ~'m-plus (:m-plus name#)] - (with-symbol-macros ~@exprs))) - -(defmacro domonad - "Monad comprehension. Takes the name of a monad, a vector of steps - given as binding-form/monadic-expression pairs, and a result value - specified by expr. The monadic-expression terms can use the binding - variables of the previous steps. - If the monad contains a definition of m-zero, the step list can also - contain conditions of the form :when p, where the predicate p can - contain the binding variables from all previous steps. - A clause of the form :let [binding-form expr ...], where the bindings - are given as a vector as for the use in let, establishes additional - bindings that can be used in the following steps." - ([steps expr] - (monad-expr steps expr)) - ([name steps expr] - (let [mexpr (monad-expr steps expr)] - `(with-monad ~name ~mexpr)))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; Defining functions used with monads -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defmacro defmonadfn - "Like defn, but for functions that use monad operations and are used inside - a with-monad block." - {:arglists '([name docstring? attr-map? args expr] - [name docstring? attr-map? (args expr) ...])} - [name & options] - (let [[name options] (name-with-attributes name options) - fn-name (symbol (str *ns*) (format "m+%s+m" (str name))) - make-fn-body (fn [args expr] - (list (vec (concat ['m-bind 'm-result - 'm-zero 'm-plus] args)) - (list `with-symbol-macros expr)))] - (if (list? (first options)) - ; multiple arities - (let [arglists (map first options) - exprs (map second options) - ] - `(do - (defsymbolmacro ~name (partial ~fn-name ~'m-bind ~'m-result - ~'m-zero ~'m-plus)) - (defn ~fn-name ~@(map make-fn-body arglists exprs)))) - ; single arity - (let [[args expr] options] - `(do - (defsymbolmacro ~name (partial ~fn-name ~'m-bind ~'m-result - ~'m-zero ~'m-plus)) - (defn ~fn-name ~@(make-fn-body args expr))))))) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; Commonly used monad functions -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -; Define the four basic monad operations as symbol macros that -; expand to their unqualified symbol equivalents. This makes it possible -; to use them inside macro templates without having to quote them. -(defsymbolmacro m-result m-result) -(defsymbolmacro m-bind m-bind) -(defsymbolmacro m-zero m-zero) -(defsymbolmacro m-plus m-plus) - -(defmacro m-lift - "Converts a function f of n arguments into a function of n - monadic arguments returning a monadic value." - [n f] - (let [expr (take n (repeatedly #(gensym "x_"))) - vars (vec (take n (repeatedly #(gensym "mv_")))) - steps (vec (interleave expr vars))] - (list `fn vars (monad-expr steps (cons f expr))))) - -(defmonadfn m-join - "Converts a monadic value containing a monadic value into a 'simple' - monadic value." - [m] - (m-bind m identity)) - -(defmonadfn m-fmap - "Bind the monadic value m to the function returning (f x) for argument x" - [f m] - (m-bind m (fn [x] (m-result (f x))))) - -(defmonadfn m-seq - "'Executes' the monadic values in ms and returns a sequence of the - basic values contained in them." - [ms] - (reduce (fn [q p] - (m-bind p (fn [x] - (m-bind q (fn [y] - (m-result (cons x y)))) ))) - (m-result '()) - (reverse ms))) - -(defmonadfn m-map - "'Executes' the sequence of monadic values resulting from mapping - f onto the values xs. f must return a monadic value." - [f xs] - (m-seq (map f xs))) - -(defmonadfn m-chain - "Chains together monadic computation steps that are each functions - of one parameter. Each step is called with the result of the previous - step as its argument. (m-chain (step1 step2)) is equivalent to - (fn [x] (domonad [r1 (step1 x) r2 (step2 r1)] r2))." - [steps] - (reduce (fn m-chain-link [chain-expr step] - (fn [v] (m-bind (chain-expr v) step))) - m-result - steps)) - -(defmonadfn m-reduce - "Return the reduction of (m-lift 2 f) over the list of monadic values mvs - with initial value (m-result val)." - ([f mvs] - (if (empty? mvs) - (m-result (f)) - (let [m-f (m-lift 2 f)] - (reduce m-f mvs)))) - ([f val mvs] - (let [m-f (m-lift 2 f) - m-val (m-result val)] - (reduce m-f m-val mvs)))) - -(defmonadfn m-until - "While (p x) is false, replace x by the value returned by the - monadic computation (f x). Return (m-result x) for the first - x for which (p x) is true." - [p f x] - (if (p x) - (m-result x) - (domonad - [y (f x) - z (m-until p f y)] - z))) - -(defmacro m-when - "If test is logical true, return monadic value m-expr, else return - (m-result nil)." - [test m-expr] - `(if ~test ~m-expr (~'m-result nil))) - -(defmacro m-when-not - "If test if logical false, return monadic value m-expr, else return - (m-result nil)." - [test m-expr] - `(if ~test (~'m-result nil) ~m-expr)) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; Utility functions used in monad definitions -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defn- flatten - "Like #(apply concat %), but fully lazy: it evaluates each sublist - only when it is needed." - [ss] - (lazy-seq - (when-let [s (seq ss)] - (concat (first s) (flatten (rest s)))))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; Commonly used monads -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -; Identity monad -(defmonad identity-m - "Monad describing plain computations. This monad does in fact nothing - at all. It is useful for testing, for combination with monad - transformers, and for code that is parameterized with a monad." - [m-result identity - m-bind (fn m-result-id [mv f] - (f mv)) - ]) - -; Maybe monad -(defmonad maybe-m - "Monad describing computations with possible failures. Failure is - represented by nil, any other value is considered valid. As soon as - a step returns nil, the whole computation will yield nil as well." - [m-zero nil - m-result (fn m-result-maybe [v] v) - m-bind (fn m-bind-maybe [mv f] - (if (nil? mv) nil (f mv))) - m-plus (fn m-plus-maybe [& mvs] - (first (drop-while nil? mvs))) - ]) - -; Sequence monad (called "list monad" in Haskell) -(defmonad sequence-m - "Monad describing multi-valued computations, i.e. computations - that can yield multiple values. Any object implementing the seq - protocol can be used as a monadic value." - [m-result (fn m-result-sequence [v] - (list v)) - m-bind (fn m-bind-sequence [mv f] - (flatten (map f mv))) - m-zero (list) - m-plus (fn m-plus-sequence [& mvs] - (flatten mvs)) - ]) - -; Set monad -(defmonad set-m - "Monad describing multi-valued computations, like sequence-m, - but returning sets of results instead of sequences of results." - [m-result (fn m-result-set [v] - #{v}) - m-bind (fn m-bind-set [mv f] - (apply clojure.set/union (map f mv))) - m-zero #{} - m-plus (fn m-plus-set [& mvs] - (apply clojure.set/union mvs)) - ]) - -; State monad -(defmonad state-m - "Monad describing stateful computations. The monadic values have the - structure (fn [old-state] [result new-state])." - [m-result (fn m-result-state [v] - (fn [s] [v s])) - m-bind (fn m-bind-state [mv f] - (fn [s] - (let [[v ss] (mv s)] - ((f v) ss)))) - ]) - -(defn update-state - "Return a state-monad function that replaces the current state by the - result of f applied to the current state and that returns the old state." - [f] - (fn [s] [s (f s)])) - -(defn set-state - "Return a state-monad function that replaces the current state by s and - returns the previous state." - [s] - (update-state (fn [_] s))) - -(defn fetch-state - "Return a state-monad function that returns the current state and does not - modify it." - [] - (update-state identity)) - -(defn fetch-val - "Return a state-monad function that assumes the state to be a map and - returns the value corresponding to the given key. The state is not modified." - [key] - (domonad state-m - [s (fetch-state)] - (key s))) - -(defn update-val - "Return a state-monad function that assumes the state to be a map and - replaces the value associated with the given key by the return value - of f applied to the old value. The old value is returned." - [key f] - (fn [s] - (let [old-val (get s key) - new-s (assoc s key (f old-val))] - [old-val new-s]))) - -(defn set-val - "Return a state-monad function that assumes the state to be a map and - replaces the value associated with key by val. The old value is returned." - [key val] - (update-val key (fn [_] val))) - -(defn with-state-field - "Returns a state-monad function that expects a map as its state and - runs statement (another state-monad function) on the state defined by - the map entry corresponding to key. The map entry is updated with the - new state returned by statement." - [key statement] - (fn [s] - (let [substate (get s key nil) - [result new-substate] (statement substate) - new-state (assoc s key new-substate)] - [result new-state]))) - -(defn state-m-until - "An optimized implementation of m-until for the state monad that - replaces recursion by a loop." - [p f x] - (letfn [(until [p f x s] - (if (p x) - [x s] - (let [[x s] ((f x) s)] - (recur p f x s))))] - (fn [s] (until p f x s)))) - -; Writer monad -(defn writer-m - "Monad describing computations that accumulate data on the side, e.g. for - logging. The monadic values have the structure [value log]. Any of the - accumulators from clojure.contrib.accumulators can be used for storing the - log data. Its empty value is passed as a parameter." - [empty-accumulator] - (monad - [m-result (fn m-result-writer [v] - [v empty-accumulator]) - m-bind (fn m-bind-writer [mv f] - (let [[v1 a1] mv - [v2 a2] (f v1)] - [v2 (clojure.contrib.accumulators/combine a1 a2)])) - ])) - -(defmonadfn write [v] - (let [[_ a] (m-result nil)] - [nil (clojure.contrib.accumulators/add a v)])) - -(defn listen [mv] - (let [[v a] mv] [[v a] a])) - -(defn censor [f mv] - (let [[v a] mv] [v (f a)])) - -; Continuation monad - -(defmonad cont-m - "Monad describing computations in continuation-passing style. The monadic - values are functions that are called with a single argument representing - the continuation of the computation, to which they pass their result." - [m-result (fn m-result-cont [v] - (fn [c] (c v))) - m-bind (fn m-bind-cont [mv f] - (fn [c] - (mv (fn [v] ((f v) c))))) - ]) - -(defn run-cont - "Execute the computation c in the cont monad and return its result." - [c] - (c identity)) - -(defn call-cc - "A computation in the cont monad that calls function f with a single - argument representing the current continuation. The function f should - return a continuation (which becomes the return value of call-cc), - or call the passed-in current continuation to terminate." - [f] - (fn [c] - (let [cc (fn cc [a] (fn [_] (c a))) - rc (f cc)] - (rc c)))) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; Monad transformers -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defmacro monad-transformer - "Define a monad transforer in terms of the monad operations and the base - monad. The argument which-m-plus chooses if m-zero and m-plus are taken - from the base monad or from the transformer." - [base which-m-plus operations] - `(let [which-m-plus# (cond (= ~which-m-plus :m-plus-default) - (if (= ::undefined (with-monad ~base ~'m-plus)) - :m-plus-from-transformer - :m-plus-from-base) - (or (= ~which-m-plus :m-plus-from-base) - (= ~which-m-plus :m-plus-from-transformer)) - ~which-m-plus - :else - (throw (java.lang.IllegalArgumentException. - "undefined m-plus choice"))) - combined-monad# (monad ~operations)] - (if (= which-m-plus# :m-plus-from-base) - (assoc combined-monad# - :m-zero (with-monad ~base ~'m-zero) - :m-plus (with-monad ~base ~'m-plus)) - combined-monad#))) - -(defn maybe-t - "Monad transformer that transforms a monad m into a monad in which - the base values can be invalid (represented by nothing, which defaults - to nil). The third argument chooses if m-zero and m-plus are inherited - from the base monad (use :m-plus-from-base) or adopt maybe-like - behaviour (use :m-plus-from-transformer). The default is :m-plus-from-base - if the base monad m has a definition for m-plus, and - :m-plus-from-transformer otherwise." - ([m] (maybe-t m nil :m-plus-default)) - ([m nothing] (maybe-t m nothing :m-plus-default)) - ([m nothing which-m-plus] - (monad-transformer m which-m-plus - [m-result (with-monad m m-result) - m-bind (with-monad m - (fn m-bind-maybe-t [mv f] - (m-bind mv - (fn [x] - (if (identical? x nothing) - (m-result nothing) - (f x)))))) - m-zero (with-monad m (m-result nothing)) - m-plus (with-monad m - (fn m-plus-maybe-t [& mvs] - (if (empty? mvs) - (m-result nothing) - (m-bind (first mvs) - (fn [v] - (if (= v nothing) - (apply m-plus-maybe-t (rest mvs)) - (m-result v))))))) - ]))) - -(defn sequence-t - "Monad transformer that transforms a monad m into a monad in which - the base values are sequences. The argument which-m-plus chooses - if m-zero and m-plus are inherited from the base monad - (use :m-plus-from-base) or adopt sequence-like - behaviour (use :m-plus-from-transformer). The default is :m-plus-from-base - if the base monad m has a definition for m-plus, and - :m-plus-from-transformer otherwise." - ([m] (sequence-t m :m-plus-default)) - ([m which-m-plus] - (monad-transformer m which-m-plus - [m-result (with-monad m - (fn m-result-sequence-t [v] - (m-result (list v)))) - m-bind (with-monad m - (fn m-bind-sequence-t [mv f] - (m-bind mv - (fn [xs] - (m-fmap flatten - (m-map f xs)))))) - m-zero (with-monad m (m-result (list))) - m-plus (with-monad m - (fn m-plus-sequence-t [& mvs] - (m-reduce concat (list) mvs))) - ]))) - -;; Contributed by Jim Duey -(defn state-t - "Monad transformer that transforms a monad m into a monad of stateful - computations that have the base monad type as their result." - [m] - (monad [m-result (with-monad m - (fn m-result-state-t [v] - (fn [s] - (m-result [v s])))) - m-bind (with-monad m - (fn m-bind-state-t [stm f] - (fn [s] - (m-bind (stm s) - (fn [[v ss]] - ((f v) ss)))))) - m-zero (with-monad m - (if (= ::undefined m-zero) - ::undefined - (fn [s] - m-zero))) - m-plus (with-monad m - (if (= ::undefined m-plus) - ::undefined - (fn [& stms] - (fn [s] - (apply m-plus (map #(% s) stms)))))) - ])) diff --git a/src/clojure/contrib/monads/examples.clj b/src/clojure/contrib/monads/examples.clj deleted file mode 100644 index 00e5dfaf..00000000 --- a/src/clojure/contrib/monads/examples.clj +++ /dev/null @@ -1,425 +0,0 @@ -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; Monad application examples -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(ns - #^{:author "Konrad Hinsen" - :skip-wiki true - :doc "Examples for using monads"} - clojure.contrib.monads.examples - (:use [clojure.contrib.monads - :only (domonad with-monad m-lift m-seq m-reduce m-when - sequence-m - maybe-m - state-m fetch-state set-state - writer-m write - cont-m run-cont call-cc - maybe-t)]) - (:require (clojure.contrib [accumulators :as accu]))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; Sequence manipulations with the sequence monad -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -; Note: in the Haskell world, this monad is called the list monad. -; The Clojure equivalent to Haskell's lists are (possibly lazy) -; sequences. This is why I call this monad "sequence". All sequences -; created by sequence monad operations are lazy. - -; Monad comprehensions in the sequence monad work exactly the same -; as Clojure's 'for' construct, except that :while clauses are not -; available. -(domonad sequence-m - [x (range 5) - y (range 3)] - (+ x y)) - -; Inside a with-monad block, domonad is used without the monad name. -(with-monad sequence-m - (domonad - [x (range 5) - y (range 3)] - (+ x y))) - -; Conditions are written with :when, as in Clojure's for form: -(domonad sequence-m - [x (range 5) - y (range (+ 1 x)) - :when (= (+ x y) 2)] - (list x y)) - -; :let is also supported like in for: -(domonad sequence-m - [x (range 5) - y (range (+ 1 x)) - :let [sum (+ x y) - diff (- x y)] - :when (= sum 2)] - (list diff)) - -; An example of a sequence function defined in terms of a lift operation. -(with-monad sequence-m - (defn pairs [xs] - ((m-lift 2 #(list %1 %2)) xs xs))) - -(pairs (range 5)) - -; Another way to define pairs is through the m-seq operation. It takes -; a sequence of monadic values and returns a monadic value containing -; the sequence of the underlying values, obtained from chaining together -; from left to right the monadic values in the sequence. -(with-monad sequence-m - (defn pairs [xs] - (m-seq (list xs xs)))) - -(pairs (range 5)) - -; This definition suggests a generalization: -(with-monad sequence-m - (defn ntuples [n xs] - (m-seq (replicate n xs)))) - -(ntuples 2 (range 5)) -(ntuples 3 (range 5)) - -; Lift operations can also be used inside a monad comprehension: -(domonad sequence-m - [x ((m-lift 1 (partial * 2)) (range 5)) - y (range 2)] - [x y]) - -; The m-plus operation does concatenation in the sequence monad. -(domonad sequence-m - [x ((m-lift 2 +) (range 5) (range 3)) - y (m-plus (range 2) '(10 11))] - [x y]) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; Handling failures with the maybe monad -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -; Maybe monad versions of basic arithmetic -(with-monad maybe-m - (def m+ (m-lift 2 +)) - (def m- (m-lift 2 -)) - (def m* (m-lift 2 *))) - -; Division is special for two reasons: we can't call it m/ because that's -; not a legal Clojure symbol, and we want it to fail if a division by zero -; is attempted. It is best defined by a monad comprehension with a -; :when clause: -(defn safe-div [x y] - (domonad maybe-m - [a x - b y - :when (not (zero? b))] - (/ a b))) - -; Now do some non-trivial computation with division -; It fails for (1) x = 0, (2) y = 0 or (3) y = -x. -(with-monad maybe-m - (defn some-function [x y] - (let [one (m-result 1)] - (safe-div one (m+ (safe-div one (m-result x)) - (safe-div one (m-result y))))))) - -; An example that doesn't fail: -(some-function 2 3) -; And two that do fail, at different places: -(some-function 2 0) -(some-function 2 -2) - -; In the maybe monad, m-plus selects the first monadic value that -; holds a valid value. -(with-monad maybe-m - (m-plus (some-function 2 0) (some-function 2 -2) (some-function 2 3))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; Random numbers with the state monad -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -; A state monad item represents a computation that changes a state and -; returns a value. Its structure is a function that takes a state argument -; and returns a two-item list containing the value and the updated state. -; It is important to realize that everything you put into a state monad -; expression is a state monad item (thus a function), and everything you -; get out as well. A state monad does not perform a calculation, it -; constructs a function that does the computation when called. - -; First, we define a simple random number generator with explicit state. -; rng is a function of its state (an integer) that returns the -; pseudo-random value derived from this state and the updated state -; for the next iteration. This is exactly the structure of a state -; monad item. -(defn rng [seed] - (let [m 259200 - value (/ (float seed) (float m)) - next (rem (+ 54773 (* 7141 seed)) m)] - [value next])) - -; We define a convenience function that creates an infinite lazy seq -; of values obtained from iteratively applying a state monad value. -(defn value-seq [f seed] - (lazy-seq - (let [[value next] (f seed)] - (cons value (value-seq f next))))) - -; Next, we define basic statistics functions to check our random numbers -(defn sum [xs] (apply + xs)) -(defn mean [xs] (/ (sum xs) (count xs))) -(defn variance [xs] - (let [m (mean xs) - sq #(* % %)] - (mean (for [x xs] (sq (- x m)))))) - -; rng implements a uniform distribution in the interval [0., 1.), so -; ideally, the mean would be 1/2 (0.5) and the variance 1/12 (0.8333). -(mean (take 1000 (value-seq rng 1))) -(variance (take 1000 (value-seq rng 1))) - -; We make use of the state monad to implement a simple (but often sufficient) -; approximation to a Gaussian distribution: the sum of 12 random numbers -; from rng's distribution, shifted by -6, has a distribution that is -; approximately Gaussian with 0 mean and variance 1, by virtue of the central -; limit theorem. -; In the first version, we call rng 12 times explicitly and calculate the -; shifted sum in a monad comprehension: -(def gaussian1 - (domonad state-m - [x1 rng - x2 rng - x3 rng - x4 rng - x5 rng - x6 rng - x7 rng - x8 rng - x9 rng - x10 rng - x11 rng - x12 rng] - (- (+ x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12) 6.))) - -; Let's test it: -(mean (take 1000 (value-seq gaussian1 1))) -(variance (take 1000 (value-seq gaussian1 1))) - -; Of course, we'd rather have a loop construct for creating the 12 -; random numbers. This would be easy if we could define a summation -; operation on random-number generators, which would then be used in -; combination with reduce. The lift operation gives us exactly that. -; More precisely, we need (m-lift 2 +), because we want both arguments -; of + to be lifted to the state monad: -(def gaussian2 - (domonad state-m - [sum12 (reduce (m-lift 2 +) (replicate 12 rng))] - (- sum12 6.))) - -; Such a reduction is often quite useful, so there's m-reduce predefined -; to simplify it: -(def gaussian2 - (domonad state-m - [sum12 (m-reduce + (replicate 12 rng))] - (- sum12 6.))) - -; The statistics should be strictly the same as above, as long as -; we use the same seed: -(mean (take 1000 (value-seq gaussian2 1))) -(variance (take 1000 (value-seq gaussian2 1))) - -; We can also do the subtraction of 6 in a lifted function, and get rid -; of the monad comprehension altogether: -(with-monad state-m - (def gaussian3 - ((m-lift 1 #(- % 6.)) - (m-reduce + (replicate 12 rng))))) - -; Again, the statistics are the same: -(mean (take 1000 (value-seq gaussian3 1))) -(variance (take 1000 (value-seq gaussian3 1))) - -; For a random point in two dimensions, we'd like a random number generator -; that yields a list of two random numbers. The m-seq operation can easily -; provide it: -(with-monad state-m - (def rng2 (m-seq (list rng rng)))) - -; Let's test it: -(rng2 1) - -; fetch-state and get-state can be used to save the seed of the random -; number generator and go back to that saved seed later on: -(def identical-random-seqs - (domonad state-m - [seed (fetch-state) - x1 rng - x2 rng - _ (set-state seed) - y1 rng - y2 rng] - (list [x1 x2] [y1 y2]))) - -(identical-random-seqs 1) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; Logging with the writer monad -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -; A basic logging example -(domonad (writer-m accu/empty-string) - [x (m-result 1) - _ (write "first step\n") - y (m-result 2) - _ (write "second step\n")] - (+ x y)) - -; For a more elaborate application, let's trace the recursive calls of -; a naive implementation of a Fibonacci function. The starting point is: -(defn fib [n] - (if (< n 2) - n - (let [n1 (dec n) - n2 (dec n1)] - (+ (fib n1) (fib n2))))) - -; First we rewrite it to make every computational step explicit -; in a let expression: -(defn fib [n] - (if (< n 2) - n - (let [n1 (dec n) - n2 (dec n1) - f1 (fib n1) - f2 (fib n2)] - (+ f1 f2)))) - -; Next, we replace the let by a domonad in a writer monad that uses a -; vector accumulator. We can then place calls to write in between the -; steps, and obtain as a result both the return value of the function -; and the accumulated trace values. -(with-monad (writer-m accu/empty-vector) - - (defn fib-trace [n] - (if (< n 2) - (m-result n) - (domonad - [n1 (m-result (dec n)) - n2 (m-result (dec n1)) - f1 (fib-trace n1) - _ (write [n1 f1]) - f2 (fib-trace n2) - _ (write [n2 f2]) - ] - (+ f1 f2)))) - -) - -(fib-trace 5) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; Sequences with undefined value: the maybe-t monad transformer -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -; A monad transformer is a function that takes a monad argument and -; returns a monad as its result. The resulting monad adds some -; specific behaviour aspect to the input monad. - -; The simplest monad transformer is maybe-t. It adds the functionality -; of the maybe monad (handling failures or undefined values) to any other -; monad. We illustrate this by applying maybe-t to the sequence monad. -; The result is an enhanced sequence monad in which undefined values -; (represented by nil) are not subjected to any transformation, but -; lead immediately to a nil result in the output. - -; First we define the combined monad: -(def seq-maybe-m (maybe-t sequence-m)) - -; As a first illustration, we create a range of integers and replace -; all even values by nil, using a simple when expression. We use this -; sequence in a monad comprehension that yields (inc x). The result -; is a sequence in which inc has been applied to all non-nil values, -; whereas the nil values appear unmodified in the output: -(domonad seq-maybe-m - [x (for [n (range 10)] (when (odd? n) n))] - (inc x)) - -; Next we repeat the definition of the function pairs (see above), but -; using the seq-maybe monad: -(with-monad seq-maybe-m - (defn pairs-maybe [xs] - (m-seq (list xs xs)))) - -; Applying this to a sequence containing nils yields the pairs of all -; non-nil values interspersed with nils that result from any combination -; in which one or both of the values is nil: -(pairs-maybe (for [n (range 5)] (when (odd? n) n))) - -; It is important to realize that undefined values (nil) are not eliminated -; from the iterations. They are simply not passed on to any operations. -; The outcome of any function applied to arguments of which at least one -; is nil is supposed to be nil as well, and the function is never called. - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; Continuation-passing style in the cont monad -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -; A simple computation performed in continuation-passing style. -; (m-result 1) returns a function that, when called with a single -; argument f, calls (f 1). The result of the domonad-computation is -; a function that behaves in the same way, passing 3 to its function -; argument. run-cont executes a continuation by calling it on identity. -(run-cont - (domonad cont-m - [x (m-result 1) - y (m-result 2)] - (+ x y))) - -; Let's capture a continuation using call-cc. We store it in a global -; variable so that we can do with it whatever we want. The computation -; is the same one as in the first example, but it has the side effect -; of storing the continuation at (m-result 2). -(def continuation nil) - -(run-cont - (domonad cont-m - [x (m-result 1) - y (call-cc (fn [c] (def continuation c) (c 2)))] - (+ x y))) - -; Now we can call the continuation with whatever argument we want. The -; supplied argument takes the place of 2 in the above computation: -(run-cont (continuation 5)) -(run-cont (continuation 42)) -(run-cont (continuation -1)) - -; Next, a function that illustrates how a captured continuation can be -; used as an "emergency exit" out of a computation: -(defn sqrt-as-str [x] - (call-cc - (fn [k] - (domonad cont-m - [_ (m-when (< x 0) (k (str "negative argument " x)))] - (str (. Math sqrt x)))))) - -(run-cont (sqrt-as-str 2)) -(run-cont (sqrt-as-str -2)) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; diff --git a/src/clojure/contrib/ns_utils.clj b/src/clojure/contrib/ns_utils.clj deleted file mode 100644 index d77b3217..00000000 --- a/src/clojure/contrib/ns_utils.clj +++ /dev/null @@ -1,106 +0,0 @@ -;; Copyright (c) Stephen C. Gilardi. 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. -;; -;; ns-utils -;; -;; Namespace Utilities -;; -;; 'get-ns' returns the namespace named by a symbol or throws -;; if the namespace does not exist -;; -;; 'ns-vars' returns a sorted seq of symbols naming public vars -;; in a namespace -;; -;; 'print-dir' prints a sorted directory of public vars in a -;; namespace -;; -;; 'print-docs' prints documentation for the public vars in a -;; namespace -;; -;; 'immigrate' Create a public var in this namespace for each -;; public var in the namespaces named by ns-names. -;; From James Reeves -;; Convenience -;; -;; 'vars' returns a sorted seq of symbols naming public vars -;; in a namespace (macro) -;; -;; 'dir' prints a sorted directory of public vars in a -;; namespace (macro) -;; -;; 'docs' prints documentation for the public vars in a -;; namespace (macro) -;; -;; scgilardi (gmail) -;; 23 April 2008 - -(ns - #^{:author "Stephen C. Gilardi", - :doc "Namespace utilities"} - clojure.contrib.ns-utils - (:use clojure.contrib.except)) - -;; Namespace Utilities - -(defn get-ns - "Returns the namespace named by ns-sym or throws if the - namespace does not exist" - [ns-sym] - (let [ns (find-ns ns-sym)] - (throw-if (not ns) "Unable to find namespace: %s" ns-sym) - ns)) - -(defn ns-vars - "Returns a sorted seq of symbols naming public vars in - a namespace" - [ns] - (sort (map first (ns-publics ns)))) - -(defn print-dir - "Prints a sorted directory of public vars in a namespace" - [ns] - (doseq [item (ns-vars ns)] - (println item))) - -(defn print-docs - "Prints documentation for the public vars in a namespace" - [ns] - (doseq [item (ns-vars ns)] - (print-doc (ns-resolve ns item)))) - -;; Convenience - -(defmacro vars - "Returns a sorted seq of symbols naming public vars in - a namespace" - [nsname] - `(ns-vars (get-ns '~nsname))) - -(defmacro dir - "Prints a sorted directory of public vars in a namespace" - [nsname] - `(print-dir (get-ns '~nsname))) - -(defmacro docs - "Prints documentation for the public vars in a namespace" - [nsname] - `(print-docs (get-ns '~nsname))) - -(defn immigrate - "Create a public var in this namespace for each public var in the - namespaces named by ns-names. The created vars have the same name, root - binding, and metadata as the original except that their :ns metadata - value is this namespace." - [& ns-names] - (doseq [ns ns-names] - (require ns) - (doseq [[sym var] (ns-publics ns)] - (let [sym (with-meta sym (assoc (meta var) :ns *ns*))] - (if (.hasRoot var) - (intern *ns* sym (.getRoot var)) - (intern *ns* sym)))))) diff --git a/src/clojure/contrib/pprint.clj b/src/clojure/contrib/pprint.clj deleted file mode 100644 index 594cf4f3..00000000 --- a/src/clojure/contrib/pprint.clj +++ /dev/null @@ -1,35 +0,0 @@ -;;; pprint.clj -- Pretty printer and Common Lisp compatible format function (cl-format) for Clojure - -;; by Tom Faulhaber -;; April 3, 2009 - -;; Copyright (c) Tom Faulhaber, April 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. - -(ns - #^{:author "Tom Faulhaber", - :doc "This module comprises two elements: -1) A pretty printer for Clojure data structures, implemented in the - function \"pprint\" -2) A Common Lisp compatible format function, implemented as - \"cl-format\" because Clojure is using the name \"format\" - for its Java-based format function. - -See documentation for those functions for more information or complete -documentation on the the clojure-contrib web site on github.", - } - clojure.contrib.pprint - (:use clojure.contrib.pprint.utilities) - (:import [clojure.contrib.pprint PrettyWriter])) - - -(load "pprint/pprint_base") -(load "pprint/cl_format") -(load "pprint/dispatch") - -nil diff --git a/src/clojure/contrib/pprint/ColumnWriter.clj b/src/clojure/contrib/pprint/ColumnWriter.clj deleted file mode 100644 index fc6ae75c..00000000 --- a/src/clojure/contrib/pprint/ColumnWriter.clj +++ /dev/null @@ -1,89 +0,0 @@ -;;; ColumnWriter.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 a column-aware wrapper around an instance of java.io.Writer - -(ns clojure.contrib.pprint.ColumnWriter - (:gen-class - :extends java.io.Writer - :init init - :constructors {[java.io.Writer Integer] [], - [java.io.Writer] []} - :methods [[getColumn [] Integer] - [getLine [] Integer] - [getMaxColumn [] Integer] - [setMaxColumn [Integer] Void] - [getWriter [] java.io.Writer]] - :state state)) - -(def *default-page-width* 72) - -(defn- -init - ([writer] (-init writer *default-page-width*)) - ([writer max-columns] [[] (ref {:max max-columns, :cur 0, :line 0 :base writer})])) - -(defn- get-field [#^clojure.contrib.pprint.ColumnWriter this sym] - (sym @(.state this))) - -(defn- set-field [#^clojure.contrib.pprint.ColumnWriter this sym new-val] - (alter (.state this) assoc sym new-val)) - -(defn- -getColumn [this] - (get-field this :cur)) - -(defn- -getLine [this] - (get-field this :line)) - -(defn- -getMaxColumn [this] - (get-field this :max)) - -(defn- -setMaxColumn [this new-max] - (dosync (set-field this :max new-max)) - nil) - -(defn- -getWriter [this] - (get-field this :base)) - -(declare write-char) - -(defn- -write - ([#^clojure.contrib.pprint.ColumnWriter this #^chars cbuf #^Integer off #^Integer len] - (let [#^java.io.Writer writer (get-field this :base)] - (.write writer cbuf off len))) - ([#^clojure.contrib.pprint.ColumnWriter this x] - (condp = (class x) - String - (let [#^String s x - nl (.lastIndexOf s (int \newline))] - (dosync (if (neg? nl) - (set-field this :cur (+ (get-field this :cur) (count s))) - (do - (set-field this :cur (- (count s) nl 1)) - (set-field this :line (+ (get-field this :line) - (count (filter #(= % \newline) s))))))) - (.write #^java.io.Writer (get-field this :base) s)) - - Integer - (write-char this x)))) - -(defn- write-char [#^clojure.contrib.pprint.ColumnWriter this #^Integer c] - (dosync (if (= c (int \newline)) - (do - (set-field this :cur 0) - (set-field this :line (inc (get-field this :line)))) - (set-field this :cur (inc (get-field this :cur))))) - (.write #^java.io.Writer (get-field this :base) c)) - -(defn- -flush [this]) ;; Currently a no-op - -(defn- -close [this]) ;; Currently a no-op diff --git a/src/clojure/contrib/pprint/PrettyWriter.clj b/src/clojure/contrib/pprint/PrettyWriter.clj deleted file mode 100644 index 10192097..00000000 --- a/src/clojure/contrib/pprint/PrettyWriter.clj +++ /dev/null @@ -1,486 +0,0 @@ -;;; PrettyWriter.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 a wrapper around a java.io.Writer which implements the -;; core of the XP algorithm. - -(ns clojure.contrib.pprint.PrettyWriter - (:refer-clojure :exclude (deftype)) - (:use clojure.contrib.pprint.utilities) - (:gen-class - :extends clojure.contrib.pprint.ColumnWriter - :init init - :constructors {[java.io.Writer Integer Object] [java.io.Writer Integer]} - :methods [[startBlock [String String String] void] - [endBlock [] void] - [newline [clojure.lang.Keyword] void] - [indent [clojure.lang.Keyword Integer] void] - [getMiserWidth [] Object] - [setMiserWidth [Object] void] - [setLogicalBlockCallback [clojure.lang.IFn] void]] - :exposes-methods {write col_write} - :state pwstate)) - -;; TODO: Support for tab directives - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Macros to simplify dealing with types and classes. These are -;;; really utilities, but I'm experimenting with them here. -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defmacro #^{:private true} - getf - "Get the value of the field a named by the argument (which should be a keyword)." - [sym] - `(~sym @(.pwstate ~'this))) - -(defmacro #^{:private true} - setf [sym new-val] - "Set the value of the field SYM to NEW-VAL" - `(alter (.pwstate ~'this) assoc ~sym ~new-val)) - -(defmacro deftype [type-name & fields] - (let [name-str (name type-name)] - `(do - (defstruct ~type-name :type-tag ~@fields) - (defn- ~(symbol (str "make-" name-str)) - [& vals#] (apply struct ~type-name ~(keyword name-str) vals#)) - (defn- ~(symbol (str name-str "?")) [x#] (= (:type-tag x#) ~(keyword name-str)))))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; The data structures used by PrettyWriter -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defstruct #^{:private true} logical-block - :parent :section :start-col :indent - :done-nl :intra-block-nl - :prefix :per-line-prefix :suffix - :logical-block-callback) - -(defn ancestor? [parent child] - (loop [child (:parent child)] - (cond - (nil? child) false - (identical? parent child) true - :else (recur (:parent child))))) - -(defstruct #^{:private true} section :parent) - -(defn buffer-length [l] - (let [l (seq l)] - (if l - (- (:end-pos (last l)) (:start-pos (first l))) - 0))) - -; A blob of characters (aka a string) -(deftype buffer-blob :data :trailing-white-space :start-pos :end-pos) - -; A newline -(deftype nl :type :logical-block :start-pos :end-pos) - -(deftype start-block :logical-block :start-pos :end-pos) - -(deftype end-block :logical-block :start-pos :end-pos) - -(deftype indent :logical-block :relative-to :offset :start-pos :end-pos) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Initialize the PrettyWriter instance -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defn- -init - [writer max-columns miser-width] - [[writer max-columns] - (let [lb (struct logical-block nil nil (ref 0) (ref 0) (ref false) (ref false))] - (ref {:logical-blocks lb - :sections nil - :mode :writing - :buffer [] - :buffer-block lb - :buffer-level 1 - :miser-width miser-width - :trailing-white-space nil - :pos 0}))]) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Functions to write tokens in the output buffer -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(declare emit-nl) - -(defmulti write-token #(:type-tag %2)) -(defmethod write-token :start-block [#^clojure.contrib.pprint.PrettyWriter this token] - (when-let [cb (getf :logical-block-callback)] (cb :start)) - (let [lb (:logical-block token)] - (dosync - (when-let [#^String prefix (:prefix lb)] - (.col_write this prefix)) - (let [col (.getColumn this)] - (ref-set (:start-col lb) col) - (ref-set (:indent lb) col))))) - -(defmethod write-token :end-block [#^clojure.contrib.pprint.PrettyWriter this token] - (when-let [cb (getf :logical-block-callback)] (cb :end)) - (when-let [#^String suffix (:suffix (:logical-block token))] - (.col_write this suffix))) - -(defmethod write-token :indent [#^clojure.contrib.pprint.PrettyWriter this token] - (let [lb (:logical-block token)] - (ref-set (:indent lb) - (+ (:offset token) - (condp = (:relative-to token) - :block @(:start-col lb) - :current (.getColumn this)))))) - -(defmethod write-token :buffer-blob [#^clojure.contrib.pprint.PrettyWriter this token] - (.col_write this #^String (:data token))) - -(defmethod write-token :nl [#^clojure.contrib.pprint.PrettyWriter this token] -; (prlabel wt @(:done-nl (:logical-block token))) -; (prlabel wt (:type token) (= (:type token) :mandatory)) - (if (or (= (:type token) :mandatory) - (and (not (= (:type token) :fill)) - @(:done-nl (:logical-block token)))) - (emit-nl this token) - (if-let [#^String tws (getf :trailing-white-space)] - (.col_write this tws))) - (dosync (setf :trailing-white-space nil))) - -(defn- write-tokens [#^clojure.contrib.pprint.PrettyWriter this tokens force-trailing-whitespace] - (doseq [token tokens] - (if-not (= (:type-tag token) :nl) - (if-let [#^String tws (getf :trailing-white-space)] - (.col_write this tws))) - (write-token this token) - (setf :trailing-white-space (:trailing-white-space token))) - (let [#^String tws (getf :trailing-white-space)] - (when (and force-trailing-whitespace tws) - (.col_write this tws) - (setf :trailing-white-space nil)))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; emit-nl? method defs for each type of new line. This makes -;;; the decision about whether to print this type of new line. -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - - -(defn- tokens-fit? [#^clojure.contrib.pprint.PrettyWriter this tokens] -;;; (prlabel tf? (.getColumn this) (buffer-length tokens)) - (let [maxcol (.getMaxColumn this)] - (or - (nil? maxcol) - (< (+ (.getColumn this) (buffer-length tokens)) maxcol)))) - -(defn- linear-nl? [this lb section] -; (prlabel lnl? @(:done-nl lb) (tokens-fit? this section)) - (or @(:done-nl lb) - (not (tokens-fit? this section)))) - -(defn- miser-nl? [#^clojure.contrib.pprint.PrettyWriter this lb section] - (let [miser-width (.getMiserWidth this) - maxcol (.getMaxColumn this)] - (and miser-width maxcol - (>= @(:start-col lb) (- maxcol miser-width)) - (linear-nl? this lb section)))) - -(defmulti emit-nl? (fn [t _ _ _] (:type t))) - -(defmethod emit-nl? :linear [newl this section _] - (let [lb (:logical-block newl)] - (linear-nl? this lb section))) - -(defmethod emit-nl? :miser [newl this section _] - (let [lb (:logical-block newl)] - (miser-nl? this lb section))) - -(defmethod emit-nl? :fill [newl this section subsection] - (let [lb (:logical-block newl)] - (or @(:intra-block-nl lb) - (not (tokens-fit? this subsection)) - (miser-nl? this lb section)))) - -(defmethod emit-nl? :mandatory [_ _ _ _] - true) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Various support functions -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - - -(defn- get-section [buffer] - (let [nl (first buffer) - lb (:logical-block nl) - section (seq (take-while #(not (and (nl? %) (ancestor? (:logical-block %) lb))) - (next buffer)))] - [section (seq (drop (inc (count section)) buffer))])) - -(defn- get-sub-section [buffer] - (let [nl (first buffer) - lb (:logical-block nl) - section (seq (take-while #(let [nl-lb (:logical-block %)] - (not (and (nl? %) (or (= nl-lb lb) (ancestor? nl-lb lb))))) - (next buffer)))] - section)) - -(defn- update-nl-state [lb] - (dosync - (ref-set (:intra-block-nl lb) false) - (ref-set (:done-nl lb) true) - (loop [lb (:parent lb)] - (if lb - (do (ref-set (:done-nl lb) true) - (ref-set (:intra-block-nl lb) true) - (recur (:parent lb))))))) - -(defn emit-nl [#^clojure.contrib.pprint.PrettyWriter this nl] - (.col_write this (int \newline)) - (dosync (setf :trailing-white-space nil)) - (let [lb (:logical-block nl) - #^String prefix (:per-line-prefix lb)] - (if prefix - (.col_write this prefix)) - (let [#^String istr (apply str (repeat (- @(:indent lb) (count prefix)) - \space))] - (.col_write this istr)) - (update-nl-state lb))) - -(defn- split-at-newline [tokens] - (let [pre (seq (take-while #(not (nl? %)) tokens))] - [pre (seq (drop (count pre) tokens))])) - -;;; Methods for showing token strings for debugging - -(defmulti tok :type-tag) -(defmethod tok :nl [token] - (:type token)) -(defmethod tok :buffer-blob [token] - (str \" (:data token) (:trailing-white-space token) \")) -(defmethod tok :default [token] - (:type-tag token)) -(defn toks [toks] (map tok toks)) - -;;; write-token-string is called when the set of tokens in the buffer -;;; is longer than the available space on the line - -(defn- write-token-string [this tokens] - (let [[a b] (split-at-newline tokens)] -;; (prlabel wts (toks a) (toks b)) - (if a (write-tokens this a false)) - (if b - (let [[section remainder] (get-section b) - newl (first b)] -;; (prlabel wts (toks section)) (prlabel wts (:type newl)) (prlabel wts (toks remainder)) - (let [do-nl (emit-nl? newl this section (get-sub-section b)) - result (if do-nl - (do -;; (prlabel emit-nl (:type newl)) - (emit-nl this newl) - (next b)) - b) - long-section (not (tokens-fit? this result)) - result (if long-section - (let [rem2 (write-token-string this section)] -;;; (prlabel recurse (toks rem2)) - (if (= rem2 section) - (do ; If that didn't produce any output, it has no nls - ; so we'll force it - (write-tokens this section false) - remainder) - (into [] (concat rem2 remainder)))) - result) -;; ff (prlabel wts (toks result)) - ] - result))))) - -(defn- write-line [#^clojure.contrib.pprint.PrettyWriter this] - (dosync - (loop [buffer (getf :buffer)] -;; (prlabel wl1 (toks buffer)) - (setf :buffer (into [] buffer)) - (if (not (tokens-fit? this buffer)) - (let [new-buffer (write-token-string this buffer)] -;; (prlabel wl new-buffer) - (if-not (identical? buffer new-buffer) - (recur new-buffer))))))) - -;;; Add a buffer token to the buffer and see if it's time to start -;;; writing -(defn- add-to-buffer [#^clojure.contrib.pprint.PrettyWriter this token] -; (prlabel a2b token) - (dosync - (setf :buffer (conj (getf :buffer) token)) - (if (not (tokens-fit? this (getf :buffer))) - (write-line this)))) - -;;; Write all the tokens that have been buffered -(defn- write-buffered-output [#^clojure.contrib.pprint.PrettyWriter this] - (write-line this) - (if-let [buf (getf :buffer)] - (do - (write-tokens this buf true) - (setf :buffer [])))) - -;;; If there are newlines in the string, print the lines up until the last newline, -;;; making the appropriate adjustments. Return the remainder of the string -(defn- write-initial-lines - [#^clojure.contrib.pprint.PrettyWriter this #^String s] - (let [lines (.split s "\n" -1)] - (if (= (count lines) 1) - s - (dosync - (let [#^String prefix (:per-line-prefix (first (getf :logical-blocks))) - #^String l (first lines)] - (if (= :buffering (getf :mode)) - (let [oldpos (getf :pos) - newpos (+ oldpos (count l))] - (setf :pos newpos) - (add-to-buffer this (make-buffer-blob l nil oldpos newpos)) - (write-buffered-output this)) - (.col_write this l)) - (.col_write this (int \newline)) - (doseq [#^String l (next (butlast lines))] - (.col_write this l) - (.col_write this (int \newline)) - (if prefix - (.col_write this prefix))) - (setf :buffering :writing) - (last lines)))))) - - -(defn write-white-space [#^clojure.contrib.pprint.PrettyWriter this] - (if-let [#^String tws (getf :trailing-white-space)] - (dosync - (.col_write this tws) - (setf :trailing-white-space nil)))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Writer overrides -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(declare write-char) - -(defn- -write - ([#^clojure.contrib.pprint.PrettyWriter this x] - ;; (prlabel write x (getf :mode)) - (condp = (class x) - String - (let [#^String s0 (write-initial-lines this x) - #^String s (.replaceFirst s0 "\\s+$" "") - white-space (.substring s0 (count s)) - mode (getf :mode)] - (dosync - (if (= mode :writing) - (do - (write-white-space this) - (.col_write this s) - (setf :trailing-white-space white-space)) - (let [oldpos (getf :pos) - newpos (+ oldpos (count s0))] - (setf :pos newpos) - (add-to-buffer this (make-buffer-blob s white-space oldpos newpos)))))) - - Integer - (write-char this x)))) - -(defn- write-char [#^clojure.contrib.pprint.PrettyWriter this #^Integer c] - (if (= (getf :mode) :writing) - (do - (write-white-space this) - (.col_write this c)) - (if (= c \newline) - (write-initial-lines this "\n") - (let [oldpos (getf :pos) - newpos (inc oldpos)] - (dosync - (setf :pos newpos) - (add-to-buffer this (make-buffer-blob (str (char c)) nil oldpos newpos))))))) - -(defn- -flush [#^clojure.contrib.pprint.PrettyWriter this] - (if (= (getf :mode) :buffering) - (dosync - (write-tokens this (getf :buffer) true) - (setf :buffer [])) - (write-white-space this))) - -(defn- -close [this] - (-flush this)) ;TODO: close underlying stream? - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Methods for PrettyWriter -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defn -startBlock - [#^clojure.contrib.pprint.PrettyWriter this - #^String prefix #^String per-line-prefix #^String suffix] - (dosync - (let [lb (struct logical-block (getf :logical-blocks) nil (ref 0) (ref 0) - (ref false) (ref false) - prefix per-line-prefix suffix)] - (setf :logical-blocks lb) - (if (= (getf :mode) :writing) - (do - (write-white-space this) - (when-let [cb (getf :logical-block-callback)] (cb :start)) - (if prefix - (.col_write this prefix)) - (let [col (.getColumn this)] - (ref-set (:start-col lb) col) - (ref-set (:indent lb) col))) - (let [oldpos (getf :pos) - newpos (+ oldpos (if prefix (count prefix) 0))] - (setf :pos newpos) - (add-to-buffer this (make-start-block lb oldpos newpos))))))) - -(defn -endBlock [#^clojure.contrib.pprint.PrettyWriter this] - (dosync - (let [lb (getf :logical-blocks) - #^String suffix (:suffix lb)] - (if (= (getf :mode) :writing) - (do - (write-white-space this) - (if suffix - (.col_write this suffix)) - (when-let [cb (getf :logical-block-callback)] (cb :end))) - (let [oldpos (getf :pos) - newpos (+ oldpos (if suffix (count suffix) 0))] - (setf :pos newpos) - (add-to-buffer this (make-end-block lb oldpos newpos)))) - (setf :logical-blocks (:parent lb))))) - -(defn- -newline [#^clojure.contrib.pprint.PrettyWriter this type] - (dosync - (setf :mode :buffering) - (let [pos (getf :pos)] - (add-to-buffer this (make-nl type (getf :logical-blocks) pos pos))))) - -(defn- -indent [#^clojure.contrib.pprint.PrettyWriter this relative-to offset] - (dosync - (let [lb (getf :logical-blocks)] - (if (= (getf :mode) :writing) - (do - (write-white-space this) - (ref-set (:indent lb) - (+ offset (condp = relative-to - :block @(:start-col lb) - :current (.getColumn this))))) - (let [pos (getf :pos)] - (add-to-buffer this (make-indent lb relative-to offset pos pos))))))) - -(defn- -getMiserWidth [#^clojure.contrib.pprint.PrettyWriter this] - (getf :miser-width)) - -(defn- -setMiserWidth [#^clojure.contrib.pprint.PrettyWriter this new-miser-width] - (dosync (setf :miser-width new-miser-width))) - -(defn- -setLogicalBlockCallback [#^clojure.contrib.pprint.PrettyWriter this f] - (dosync (setf :logical-block-callback f))) diff --git a/src/clojure/contrib/pprint/cl_format.clj b/src/clojure/contrib/pprint/cl_format.clj deleted file mode 100644 index 145697ff..00000000 --- a/src/clojure/contrib/pprint/cl_format.clj +++ /dev/null @@ -1,1843 +0,0 @@ -;;; 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)) - (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) - [mantissa exp] (float-parts arg) - scaled-exp (+ exp (:k params)) - add-sign (and (:at params) (not (neg? arg))) - prepend-zero (< -1.0 arg 1.0) - append-zero (and (not d) (<= (dec (count mantissa)) scaled-exp)) - [rounded-mantissa scaled-exp] (round-str mantissa scaled-exp - d (if w (- w (if add-sign 1 0)))) - fixed-repr (get-fixed rounded-mantissa scaled-exp d)] - (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 "+") - (if prepend-zero "0") - fixed-repr - (if append-zero "0"))))) - (print (str - (if add-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 _] (round-str mantissa exp d nil) - #^String fixed-repr (get-fixed rounded-mantissa 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 -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 -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)) - (.getMaxColumn #^PrettyWriter *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 (> (+ (.getColumn #^PrettyWriter *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 pretty-writer [writer] - (if (instance? PrettyWriter writer) - writer - (PrettyWriter. 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 (.getColumn #^PrettyWriter *out*))) - (prn))) - -(defn- absolute-tabulation [params navigator offsets] - (let [colnum (:colnum params) - colinc (:colinc params) - current (.getColumn #^PrettyWriter *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 (.getColumn #^PrettyWriter *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 (instance? PrettyWriter real-stream))) - (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/src/clojure/contrib/pprint/dispatch.clj b/src/clojure/contrib/pprint/dispatch.clj deleted file mode 100644 index 82db8746..00000000 --- a/src/clojure/contrib/pprint/dispatch.clj +++ /dev/null @@ -1,447 +0,0 @@ -;; 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/src/clojure/contrib/pprint/examples/hexdump.clj b/src/clojure/contrib/pprint/examples/hexdump.clj deleted file mode 100644 index fa5316ec..00000000 --- a/src/clojure/contrib/pprint/examples/hexdump.clj +++ /dev/null @@ -1,63 +0,0 @@ -;;; hexdump.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 example is a classic hexdump program written using cl-format. - -;; For some local color, it was written in Dulles Airport while waiting for a flight -;; home to San Francisco. - -(ns clojure.contrib.pprint.examples.hexdump - (:use clojure.contrib.pprint - clojure.contrib.pprint.utilities) - (:gen-class (:main true))) - -(def *buffer-length* 1024) - -(defn zip-array [base-offset arr] - (let [grouped (partition 16 arr)] - (first (map-passing-context - (fn [line offset] - [[offset - (map #(if (neg? %) (+ % 256) %) line) - (- 16 (count line)) - (map #(if (<= 32 % 126) (char %) \.) line)] - (+ 16 offset)]) - base-offset grouped)))) - - -(defn hexdump - ([in-stream] (hexdump in-stream true 0)) - ([in-stream out-stream] (hexdump [in-stream out-stream 0])) - ([in-stream out-stream offset] - (let [buf (make-array Byte/TYPE *buffer-length*)] - (loop [offset offset - count (.read in-stream buf)] - (if (neg? count) - nil - (let [bytes (take count buf) - zipped (zip-array offset bytes)] - (cl-format out-stream - "~:{~8,'0X: ~2{~8@{~#[ ~:;~2,'0X ~]~} ~}~v@{ ~}~2{~8@{~A~} ~}~%~}" - zipped) - (recur (+ offset *buffer-length*) (.read in-stream buf)))))))) - -(defn hexdump-file - ([file-name] (hexdump-file file-name true)) - ([file-name stream] - (with-open [s (java.io.FileInputStream. file-name)] - (hexdump s)))) - -;; I don't quite understand how to invoke main funcs w/o AOT yet -(defn -main [& args] - (hexdump-file (first args))) - diff --git a/src/clojure/contrib/pprint/examples/json.clj b/src/clojure/contrib/pprint/examples/json.clj deleted file mode 100644 index 3cde1751..00000000 --- a/src/clojure/contrib/pprint/examples/json.clj +++ /dev/null @@ -1,142 +0,0 @@ -;;; json.clj: A pretty printing version of the JavaScript Object Notation (JSON) generator - -;; by Tom Faulhaber, based on the version by Stuart Sierra (clojure.contrib.json.write) -;; May 9, 2009 - -;; Copyright (c) Tom Faulhaber/Stuart Sierra, 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. - - -(ns - #^{:author "Tom Faulhaber (based on the version by Stuart Sierra)", - :doc "Pretty printing JavaScript Object Notation (JSON) generator. - -This is an example of using a pretty printer dispatch function to generate JSON output", - :see-also [["http://json.org/", "JSON Home Page"]]} - clojure.contrib.pprint.examples.json - (:require [clojure.contrib.java-utils :as j]) - (:use [clojure.test :only (deftest- is)] - [clojure.contrib.pprint :only (write formatter-out)])) - - - -(defmulti dispatch-json - "The dispatch function for printing objects as JSON" - {:arglists '[[x]]} - (fn [x] (cond - (nil? x) nil ;; prevent NullPointerException on next line - (.isArray (class x)) ::array - :else (type x)))) - -;; Primitive types can be printed with Clojure's pr function. -(derive java.lang.Boolean ::pr) -(derive java.lang.Byte ::pr) -(derive java.lang.Short ::pr) -(derive java.lang.Integer ::pr) -(derive java.lang.Long ::pr) -(derive java.lang.Float ::pr) -(derive java.lang.Double ::pr) - -;; Collection types can be printed as JSON objects or arrays. -(derive java.util.Map ::object) -(derive java.util.Collection ::array) - -;; Symbols and keywords are converted to strings. -(derive clojure.lang.Symbol ::symbol) -(derive clojure.lang.Keyword ::symbol) - - -(defmethod dispatch-json ::pr [x] (pr x)) - -(defmethod dispatch-json nil [x] (print "null")) - -(defmethod dispatch-json ::symbol [x] (pr (name x))) - -(defmethod dispatch-json ::array [s] - ((formatter-out "~<[~;~@{~w~^, ~:_~}~;]~:>") s)) - -(defmethod dispatch-json ::object [m] - ((formatter-out "~<{~;~@{~<~w:~_~w~:>~^, ~_~}~;}~:>") - (for [[k v] m] [(j/as-str k) v]))) - -(defmethod dispatch-json java.lang.CharSequence [s] - (print \") - (dotimes [i (count s)] - (let [cp (Character/codePointAt s i)] - (cond - ;; Handle printable JSON escapes before ASCII - (= cp 34) (print "\\\"") - (= cp 92) (print "\\\\") - ;; Print simple ASCII characters - (< 31 cp 127) (print (.charAt s i)) - ;; Handle non-printable JSON escapes - (= cp 8) (print "\\b") - (= cp 12) (print "\\f") - (= cp 10) (print "\\n") - (= cp 13) (print "\\r") - (= cp 9) (print "\\t") - ;; Any other character is printed as Hexadecimal escape - :else (printf "\\u%04x" cp)))) - (print \")) - -(defn print-json - "Prints x as JSON. Nil becomes JSON null. Keywords become - strings, without the leading colon. Maps become JSON objects, all - other collection types become JSON arrays. Java arrays become JSON - arrays. Unicode characters in strings are escaped as \\uXXXX. - Numbers print as with pr." - [x] - (write x :dispatch dispatch-json)) - -(defn json-str - "Converts x to a JSON-formatted string." - [x] - (with-out-str (print-json x))) - - - -;;; TESTS - -;; Run these tests with -;; (clojure.test/run-tests 'clojure.contrib.print-json) - -;; Bind clojure.test/*load-tests* to false to omit these -;; tests from production code. - -(deftest- can-print-json-strings - (is (= "\"Hello, World!\"" (json-str "Hello, World!"))) - (is (= "\"\\\"Embedded\\\" Quotes\"" (json-str "\"Embedded\" Quotes")))) - -(deftest- can-print-unicode - (is (= "\"\\u1234\\u4567\"" (json-str "\u1234\u4567")))) - -(deftest- can-print-json-null - (is (= "null" (json-str nil)))) - -(deftest- can-print-json-arrays - (is (= "[1, 2, 3]" (json-str [1 2 3]))) - (is (= "[1, 2, 3]" (json-str (list 1 2 3)))) - (is (= "[1, 2, 3]" (json-str (sorted-set 1 2 3)))) - (is (= "[1, 2, 3]" (json-str (seq [1 2 3]))))) - -(deftest- can-print-java-arrays - (is (= "[1, 2, 3]" (json-str (into-array [1 2 3]))))) - -(deftest- can-print-empty-arrays - (is (= "[]" (json-str []))) - (is (= "[]" (json-str (list)))) - (is (= "[]" (json-str #{})))) - -(deftest- can-print-json-objects - (is (= "{\"a\":1, \"b\":2}" (json-str (sorted-map :a 1 :b 2))))) - -(deftest- object-keys-must-be-strings - (is (= "{\"1\":1, \"2\":2}" (json-str (sorted-map 1 1 2 2))))) - -(deftest- can-print-empty-objects - (is (= "{}" (json-str {})))) diff --git a/src/clojure/contrib/pprint/examples/multiply.clj b/src/clojure/contrib/pprint/examples/multiply.clj deleted file mode 100644 index c7e33035..00000000 --- a/src/clojure/contrib/pprint/examples/multiply.clj +++ /dev/null @@ -1,23 +0,0 @@ -;;; multiply.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 example prints a multiplication table using cl-format. - -(ns clojure.contrib.pprint.examples.multiply - (:use clojure.contrib.pprint)) - -(defn multiplication-table [limit] - (let [nums (range 1 (inc limit))] - (cl-format true "~{~{~4d~}~%~}" - (map #(map % nums) - (map #(partial * %) nums))))) diff --git a/src/clojure/contrib/pprint/examples/props.clj b/src/clojure/contrib/pprint/examples/props.clj deleted file mode 100644 index 4edb9149..00000000 --- a/src/clojure/contrib/pprint/examples/props.clj +++ /dev/null @@ -1,25 +0,0 @@ -;;; props.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 example displays a nicely formatted table of the java properties using -;; cl-format - -(ns clojure.contrib.pprint.examples.props - (:use clojure.contrib.pprint)) - -(defn show-props [stream] - (let [p (mapcat - #(vector (key %) (val %)) - (sort-by key (System/getProperties)))] - (cl-format true "~30A~A~%~{~20,,,'-A~10A~}~%~{~30A~S~%~}" - "Property" "Value" ["" "" "" ""] p))) diff --git a/src/clojure/contrib/pprint/examples/show_doc.clj b/src/clojure/contrib/pprint/examples/show_doc.clj deleted file mode 100644 index 6bf61585..00000000 --- a/src/clojure/contrib/pprint/examples/show_doc.clj +++ /dev/null @@ -1,50 +0,0 @@ -;;; show_doc.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 example uses cl-format as part of a routine to display all the doc -;; strings and function arguments from one or more namespaces. - -(ns clojure.contrib.pprint.examples.show-doc - (:use clojure.contrib.pprint)) - -(defn ns-list - ([] (ns-list nil)) - ([pattern] - (filter - (if pattern - (comp (partial re-find pattern) name ns-name) - (constantly true)) - (sort-by ns-name (all-ns))))) - -(defn show-doc - ([] (show-doc nil)) - ([pattern] - (cl-format - true - "~:{~A: ===============================================~ - ~%~{~{~a: ~{~a~^, ~}~%~a~%~}~^~%~}~2%~}" - (map - #(vector (ns-name %) - (map - (fn [f] - (let [f-meta (meta (find-var (symbol (str (ns-name %)) (str f))))] - [f (:arglists f-meta) (:doc f-meta)])) - (filter - (fn [a] (instance? clojure.lang.IFn a)) - (sort (map key (ns-publics %)))))) - (ns-list pattern))))) - -(defn create-api-file [pattern out-file] - (with-open [f (java.io.FileWriter. out-file)] - (binding [*out* f] - (show-doc pattern)))) diff --git a/src/clojure/contrib/pprint/examples/xml.clj b/src/clojure/contrib/pprint/examples/xml.clj deleted file mode 100644 index 3a2b9ae8..00000000 --- a/src/clojure/contrib/pprint/examples/xml.clj +++ /dev/null @@ -1,117 +0,0 @@ -;;; xml.clj -- a pretty print dispatch version of prxml.clj -- a compact syntax for generating XML - -;; by Tom Faulhaber, based on the original by Stuart Sierra, http://stuartsierra.com/ -;; May 13, 2009 - -;; Copyright (c) 2009 Tom Faulhaber/Stuart Sierra. 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. - - -;; See function "prxml" at the bottom of this file for documentation. - - -(ns - #^{:author "Tom Faulhaber, based on the original by Stuart Sierra", - :doc "A version of prxml that uses a pretty print dispatch function."} - clojure.contrib.pprint.examples.xml - (:use [clojure.contrib.lazy-xml :only (escape-xml)] - [clojure.contrib.java-utils :only (as-str)] - [clojure.contrib.pprint :only (formatter-out write)] - [clojure.contrib.pprint.utilities :only (prlabel)])) - -(def - #^{:doc "If true, empty tags will have a space before the closing />"} - *html-compatible* false) - -(def - #^{:doc "The number of spaces to indent sub-tags."} - *prxml-indent* 2) - -(defmulti #^{:private true} print-xml-tag (fn [tag attrs content] tag)) - -(defmethod print-xml-tag :raw! [tag attrs contents] - (doseq [c contents] (print c))) - -(defmethod print-xml-tag :comment! [tag attrs contents] - (print "<!-- ") - (doseq [c contents] (print c)) - (print " -->")) - -(defmethod print-xml-tag :decl! [tag attrs contents] - (let [attrs (merge {:version "1.0" :encoding "UTF-8"} - attrs)] - ;; Must enforce ordering of pseudo-attributes: - ((formatter-out "<?xml version=\"~a\" encoding=\"~a\"~@[ standalone=\"~a\"~]?>") - (:version attrs) (:encoding attrs) (:standalone attrs)))) - -(defmethod print-xml-tag :cdata! [tag attrs contents] - ((formatter-out "<[!CDATA[~{~a~}]]>") contents)) - -(defmethod print-xml-tag :doctype! [tag attrs contents] - ((formatter-out "<[!DOCTYPE [~{~a~}]]>") contents)) - -(defmethod print-xml-tag :default [tag attrs contents] - (let [tag-name (as-str tag) - xlated-attrs (map #(vector (as-str (key %)) (as-str (val %))) attrs)] - (if (seq contents) - ((formatter-out "~<~<<~a~1:i~{ ~:_~{~a=\"~a\"~}~}>~:>~vi~{~_~w~}~0i~_</~a>~:>") - [[tag-name xlated-attrs] *prxml-indent* contents tag-name]) - ((formatter-out "~<<~a~1:i~{~:_ ~{~a=\"~a\"~}~}/>~:>") [tag-name xlated-attrs])))) - - -(defmulti xml-dispatch class) - -(defmethod xml-dispatch clojure.lang.IPersistentVector [x] - (let [[tag & contents] x - [attrs content] (if (map? (first contents)) - [(first contents) (rest contents)] - [{} contents])] - (print-xml-tag tag attrs content))) - -(defmethod xml-dispatch clojure.lang.ISeq [x] - ;; Recurse into sequences, so we can use (map ...) inside prxml. - (doseq [c x] (xml-dispatch c))) - -(defmethod xml-dispatch clojure.lang.Keyword [x] - (print-xml-tag x {} nil)) - -(defmethod xml-dispatch String [x] - (print (escape-xml x))) - -(defmethod xml-dispatch nil [x]) - -(defmethod xml-dispatch :default [x] - (print x)) - - -(defn prxml - "Print XML to *out*. Vectors become XML tags: the first item is the - tag name; optional second item is a map of attributes. - - Sequences are processed recursively, so you can use map and other - sequence functions inside prxml. - - (prxml [:p {:class \"greet\"} [:i \"Ladies & gentlemen\"]]) - ; => <p class=\"greet\"><i>Ladies & gentlemen</i></p> - - PSEUDO-TAGS: some keywords have special meaning: - - :raw! do not XML-escape contents - :comment! create an XML comment - :decl! create an XML declaration, with attributes - :cdata! create a CDATA section - :doctype! create a DOCTYPE! - - (prxml [:p [:raw! \"<i>here & gone</i>\"]]) - ; => <p><i>here & gone</i></p> - - (prxml [:decl! {:version \"1.1\"}]) - ; => <?xml version=\"1.1\" encoding=\"UTF-8\"?>" - [& args] - (doseq [arg args] (write arg :dispatch xml-dispatch)) - (when (pos? (count args)) (newline))) diff --git a/src/clojure/contrib/pprint/pprint_base.clj b/src/clojure/contrib/pprint/pprint_base.clj deleted file mode 100644 index 064fc5ec..00000000 --- a/src/clojure/contrib/pprint/pprint_base.clj +++ /dev/null @@ -1,342 +0,0 @@ -;;; 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] (instance? PrettyWriter 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] - (PrettyWriter. 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 (.getColumn #^PrettyWriter *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 #^PrettyWriter *out* "#") - (binding [*current-level* (inc *current-level*) - *current-length* 0] - (.startBlock #^PrettyWriter *out* - ~(:prefix options) ~(:per-line-prefix options) ~(:suffix options)) - ~@body - (.endBlock #^PrettyWriter *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}) - (.newline #^PrettyWriter *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 #^PrettyWriter *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/src/clojure/contrib/pprint/utilities.clj b/src/clojure/contrib/pprint/utilities.clj deleted file mode 100644 index 128c66e5..00000000 --- a/src/clojure/contrib/pprint/utilities.clj +++ /dev/null @@ -1,104 +0,0 @@ -;;; utilities.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 some utility function used in formatting and pretty -;; printing. The functions here could go in a more general purpose library, -;; perhaps. - -(ns clojure.contrib.pprint.utilities) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Helper functions for digesting formats in the various -;;; phases of their lives. -;;; These functions are actually pretty general. -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defn map-passing-context [func initial-context lis] - (loop [context initial-context - lis lis - acc []] - (if (empty? lis) - [acc context] - (let [this (first lis) - remainder (next lis) - [result new-context] (apply func [this context])] - (recur new-context remainder (conj acc result)))))) - -(defn consume [func initial-context] - (loop [context initial-context - acc []] - (let [[result new-context] (apply func [context])] - (if (not result) - [acc new-context] - (recur new-context (conj acc result)))))) - -(defn consume-while [func initial-context] - (loop [context initial-context - acc []] - (let [[result continue new-context] (apply func [context])] - (if (not continue) - [acc context] - (recur new-context (conj acc result)))))) - -(defn unzip-map [m] - "Take a map that has pairs in the value slots and produce a pair of maps, - the first having all the first elements of the pairs and the second all - the second elements of the pairs" - [(into {} (for [[k [v1 v2]] m] [k v1])) - (into {} (for [[k [v1 v2]] m] [k v2]))]) - -(defn tuple-map [m v1] - "For all the values, v, in the map, replace them with [v v1]" - (into {} (for [[k v] m] [k [v v1]]))) - -(defn rtrim [s c] - "Trim all instances of c from the end of sequence s" - (let [len (count s)] - (if (and (pos? len) (= (nth s (dec (count s))) c)) - (loop [n (dec len)] - (cond - (neg? n) "" - (not (= (nth s n) c)) (subs s 0 (inc n)) - true (recur (dec n)))) - s))) - -(defn ltrim [s c] - "Trim all instances of c from the beginning of sequence s" - (let [len (count s)] - (if (and (pos? len) (= (nth s 0) c)) - (loop [n 0] - (if (or (= n len) (not (= (nth s n) c))) - (subs s n) - (recur (inc n)))) - s))) - -(defn prefix-count [aseq val] - "Return the number of times that val occurs at the start of sequence aseq, -if val is a seq itself, count the number of times any element of val occurs at the -beginning of aseq" - (let [test (if (coll? val) (set val) #{val})] - (loop [pos 0] - (if (or (= pos (count aseq)) (not (test (nth aseq pos)))) - pos - (recur (inc pos)))))) - -(defn prerr [& args] - "Println to *err*" - (binding [*out* *err*] - (apply println args))) - -(defmacro prlabel [prefix arg & more-args] - "Print args to *err* in name = value format" - `(prerr ~@(cons (list 'quote prefix) (mapcat #(list (list 'quote %) "=" %) - (cons arg (seq more-args)))))) - diff --git a/src/clojure/contrib/probabilities/examples_finite_distributions.clj b/src/clojure/contrib/probabilities/examples_finite_distributions.clj deleted file mode 100644 index 56f25bad..00000000 --- a/src/clojure/contrib/probabilities/examples_finite_distributions.clj +++ /dev/null @@ -1,209 +0,0 @@ -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; Probability distribution application examples -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(ns - #^{:author "Konrad Hinsen" - :skip-wiki true - :doc "Examples for finite probability distribution"} - clojure.contrib.probabilities.examples-finite-distributions - (:use [clojure.contrib.probabilities.finite-distributions - :only (uniform prob cond-prob join-with dist-m choose - normalize certainly cond-dist-m normalize-cond)]) - (:use [clojure.contrib.monads - :only (domonad with-monad m-seq m-chain m-lift)]) - (:require clojure.contrib.accumulators)) - -;; Simple examples using dice - -; A single die is represented by a uniform distribution over the -; six possible outcomes. -(def die (uniform #{1 2 3 4 5 6})) - -; The probability that the result is odd... -(prob odd? die) -; ... or greater than four. -(prob #(> % 4) die) - -; The sum of two dice -(def two-dice (join-with + die die)) -(prob #(> % 6) two-dice) - -; The sum of two dice using a monad comprehension -(assert (= two-dice - (domonad dist-m - [d1 die - d2 die] - (+ d1 d2)))) - -; The two values separately, but as an ordered pair -(domonad dist-m - [d1 die - d2 die] - (if (< d1 d2) (list d1 d2) (list d2 d1))) - -; The conditional probability for two dice yielding X if X is odd: -(cond-prob odd? two-dice) - -; A two-step experiment: throw a die, and then add 1 with probability 1/2 -(domonad dist-m - [d die - x (choose (/ 1 2) d - :else (inc d))] - x) - -; The sum of n dice -(defn dice [n] - (domonad dist-m - [ds (m-seq (replicate n die))] - (apply + ds))) - -(assert (= two-dice (dice 2))) - -(dice 3) - - -;; Construct an empirical distribution from counters - -; Using an ordinary counter: -(def dist1 - (normalize - (clojure.contrib.accumulators/add-items - clojure.contrib.accumulators/empty-counter - (for [_ (range 1000)] (rand-int 5))))) - -; Or, more efficiently, using a counter that already keeps track of its total: -(def dist2 - (normalize - (clojure.contrib.accumulators/add-items - clojure.contrib.accumulators/empty-counter-with-total - (for [_ (range 1000)] (rand-int 5))))) - - -;; The Monty Hall game -;; (see http://en.wikipedia.org/wiki/Monty_Hall_problem for a description) - -; The set of doors. In the classical variant, there are three doors, -; but the code can also work with more than three doors. -(def doors #{:A :B :C}) - -; A simulation of the game, step by step: -(domonad dist-m - [; The prize is hidden behind one of the doors. - prize (uniform doors) - ; The player make his initial choice. - choice (uniform doors) - ; The host opens a door which is neither the prize door nor the - ; one chosen by the player. - opened (uniform (disj doors prize choice)) - ; If the player stays with his initial choice, the game ends and the - ; following line should be commented out. It describes the switch from - ; the initial choice to a door that is neither the opened one nor - ; his original choice. - choice (uniform (disj doors opened choice)) - ] - ; If the chosen door has the prize behind it, the player wins. - (if (= choice prize) :win :loose)) - - -;; Tree growth simulation -;; Adapted from the code in: -;; Martin Erwig and Steve Kollmansberger, -;; "Probabilistic Functional Programming in Haskell", -;; Journal of Functional Programming, Vol. 16, No. 1, 21-34, 2006 -;; http://web.engr.oregonstate.edu/~erwig/papers/abstracts.html#JFP06a - -; A tree is represented by two attributes: its state (alive, hit, fallen), -; and its height (an integer). A new tree starts out alive and with zero height. -(def new-tree {:state :alive, :height 0}) - -; An evolution step in the simulation modifies alive trees only. They can -; either grow by one (90% probability), be hit by lightning and then stop -; growing (4% probability), or fall down (6% probability). -(defn evolve-1 [tree] - (let [{s :state h :height} tree] - (if (= s :alive) - (choose 0.9 (assoc tree :height (inc (:height tree))) - 0.04 (assoc tree :state :hit) - :else {:state :fallen, :height 0}) - (certainly tree)))) - -; Multiple evolution steps can be chained together with m-chain, -; since each step's input is the output of the previous step. -(with-monad dist-m - (defn evolve [n tree] - ((m-chain (replicate n evolve-1)) tree))) - -; Try it for zero, one, or two steps. -(evolve 0 new-tree) -(evolve 1 new-tree) -(evolve 2 new-tree) - -; We can also get a distribution of the height only: -(with-monad dist-m - ((m-lift 1 :height) (evolve 2 new-tree))) - - - -;; Bayesian inference -;; -;; Suppose someone has three dice, one with six faces, one with eight, and -;; one with twelve. This person throws one die and gives us the number, -;; but doesn't tell us which die it was. What are the Bayesian probabilities -;; for each of the three dice, given the observation we have? - -; A function that returns the distribution of a dice with n faces. -(defn die-n [n] (uniform (range 1 (inc n)))) - -; The three dice in the game with their distributions. With this map, we -; can easily calculate the probability for an observation under the -; condition that a particular die was used. -(def dice {:six (die-n 6) - :eight (die-n 8) - :twelve (die-n 12)}) - -; The only prior knowledge is that one of the three dice is used, so we -; have no better than a uniform distribution to start with. -(def prior (uniform (keys dice))) - -; Add a single observation to the information contained in the -; distribution. Adding an observation consists of -; 1) Draw a die from the prior distribution. -; 2) Draw an observation from the distribution of that die. -; 3) Eliminate (replace by nil) the trials that do not match the observation. -; 4) Normalize the distribution for the non-nil values. -(defn add-observation [prior observation] - (normalize-cond - (domonad cond-dist-m - [die prior - number (get dice die) - :when (= number observation) ] - die))) - -; Add one observation. -(add-observation prior 1) - -; Add three consecutive observations. -(-> prior (add-observation 1) - (add-observation 3) - (add-observation 7)) - -; We can also add multiple observations in a single trial, but this -; is slower because more combinations have to be taken into account. -; With Bayesian inference, it is most efficient to eliminate choices -; as early as possible. -(defn add-observations [prior observations] - (with-monad cond-dist-m - (let [n-nums #(m-seq (replicate (count observations) (get dice %)))] - (normalize-cond - (domonad - [die prior - nums (n-nums die) - :when (= nums observations)] - die))))) - -(add-observations prior [1 3 7]) diff --git a/src/clojure/contrib/probabilities/examples_monte_carlo.clj b/src/clojure/contrib/probabilities/examples_monte_carlo.clj deleted file mode 100644 index 44c6a7e2..00000000 --- a/src/clojure/contrib/probabilities/examples_monte_carlo.clj +++ /dev/null @@ -1,73 +0,0 @@ -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; Monte-Carlo application examples -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(ns - #^{:author "Konrad Hinsen" - :skip-wiki true - :doc "Examples for monte carlo methods"} - clojure.contrib.probabilities.random.examples-monte-carlo - (:require [clojure.contrib.generic.collection :as gc]) - (:use [clojure.contrib.probabilities.random-numbers - :only (lcg rand-stream)]) - (:use [clojure.contrib.probabilities.finite-distributions - :only (uniform)]) - (:use [clojure.contrib.probabilities.monte-carlo - :only (random-stream discrete interval normal lognormal exponential - n-sphere - sample sample-sum sample-mean sample-mean-variance)] - :reload) - (:use [clojure.contrib.monads - :only (domonad state-m)])) - -; Create a linear congruential generator -(def urng (lcg 259200 7141 54773 1)) - -;; Use Clojure's built-in random number generator -;(def urng rand-stream) - -; Sample transformed distributions -(defn sample-distribution - [n rt] - (take n (gc/seq (random-stream rt urng)))) - -; Interval [-2, 2) -(sample-distribution 10 (interval -2 2)) -; Compare with a direct transformation -(= (sample-distribution 10 (interval -2 2)) - (map (fn [x] (- (* 4 x) 2)) (take 10 (gc/seq urng)))) - -; Normal distribution -(sample-distribution 10 (normal 0 1)) - -; Log-Normal distribution -(sample-distribution 10 (lognormal 0 1)) - -; Exponential distribution -(sample-distribution 10 (exponential 1)) - -; n-sphere distribution -(sample-distribution 10 (n-sphere 2 1)) - -; Discrete distribution -(sample-distribution 10 (discrete (uniform (range 1 7)))) - -; Compose distributions in the state monad -(def sum-two-dists - (domonad state-m - [r1 (interval -2 2) - r2 (normal 0 1)] - (+ r1 r2))) - -(sample-distribution 10 sum-two-dists) - -; Distribution transformations -(sample-distribution 5 (sample 2 (interval -2 2))) -(sample-distribution 10 (sample-sum 10 (interval -2 2))) -(sample-distribution 10 (sample-mean 10 (interval -2 2))) -(sample-distribution 10 (sample-mean-variance 10 (interval -2 2))) - diff --git a/src/clojure/contrib/probabilities/finite_distributions.clj b/src/clojure/contrib/probabilities/finite_distributions.clj deleted file mode 100644 index a93aa0d8..00000000 --- a/src/clojure/contrib/probabilities/finite_distributions.clj +++ /dev/null @@ -1,203 +0,0 @@ -;; Finite probability distributions - -;; by Konrad Hinsen -;; last updated January 8, 2010 - -;; Copyright (c) Konrad Hinsen, 2009-2010. 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. - -(ns - #^{:author "Konrad Hinsen" - :doc "Finite probability distributions - This library defines a monad for combining finite probability - distributions."} - clojure.contrib.probabilities.finite-distributions - (:use [clojure.contrib.monads - :only (defmonad domonad with-monad maybe-t m-lift m-chain)] - [clojure.contrib.def :only (defvar)])) - -; The probability distribution monad. It is limited to finite probability -; distributions (e.g. there is a finite number of possible value), which -; are represented as maps from values to probabilities. - -(defmonad dist-m - "Monad describing computations on fuzzy quantities, represented by a finite - probability distribution for the possible values. A distribution is - represented by a map from values to probabilities." - [m-result (fn m-result-dist [v] - {v 1}) - m-bind (fn m-bind-dist [mv f] - (reduce (partial merge-with +) - (for [[x p] mv [y q] (f x)] - {y (* q p)}))) - ]) - -; Applying the monad transformer maybe-t to the basic dist monad results -; in the cond-dist monad that can handle invalid values. The total probability -; for invalid values ends up as the probability of m-zero (which is nil). -; The function normalize takes this probability out of the distribution and -; re-distributes its weight over the valid values. - -(defvar cond-dist-m - (maybe-t dist-m) - "Variant of the dist monad that can handle undefined values.") - -; Normalization - -(defn- scale-by - "Multiply each entry in dist by the scale factor s and remove zero entries." - [dist s] - (into {} - (for [[val p] dist :when (> p 0)] - [val (* p s)]))) - -(defn normalize-cond [cdist] - "Normalize a probability distribution resulting from a computation in - the cond-dist monad by re-distributing the weight of the invalid values - over the valid ones." - (let [missing (get cdist nil 0) - dist (dissoc cdist nil)] - (cond (zero? missing) dist - (= 1 missing) {} - :else (let [scale (/ 1 (- 1 missing))] - (scale-by dist scale))))) - -(defn normalize - "Convert a weight map (e.g. a map of counter values) to a distribution - by multiplying with a normalization factor. If the map has a key - :total, its value is assumed to be the sum over all the other values and - it is used for normalization. Otherwise, the sum is calculated - explicitly. The :total key is removed from the resulting distribution." - [weights] - (let [total (:total weights) - w (dissoc weights :total) - s (/ 1 (if (nil? total) (reduce + (vals w)) total))] - (scale-by w s))) - -; Functions that construct distributions - -(defn uniform - "Return a distribution in which each of the elements of coll - has the same probability." - [coll] - (let [n (count coll) - p (/ 1 n)] - (into {} (for [x (seq coll)] [x p])))) - -(defn choose - "Construct a distribution from an explicit list of probabilities - and values. They are given in the form of a vector of probability-value - pairs. In the last pair, the probability can be given by the keyword - :else, which stands for 1 minus the total of the other probabilities." - [& choices] - (letfn [(add-choice [dist [p v]] - (cond (nil? p) dist - (= p :else) - (let [total-p (reduce + (vals dist))] - (assoc dist v (- 1 total-p))) - :else (assoc dist v p)))] - (reduce add-choice {} (partition 2 choices)))) - -(defn bernoulli - [p] - "Returns the Bernoulli distribution for probability p." - (choose p 1 :else 0)) - -(defn- bc - [n] - "Returns the binomial coefficients for a given n." - (let [r (inc n)] - (loop [c 1 - f (list 1)] - (if (> c n) - f - (recur (inc c) (cons (* (/ (- r c) c) (first f)) f)))))) - -(defn binomial - [n p] - "Returns the binomial distribution, which is the distribution of the - number of successes in a series of n experiments whose individual - success probability is p." - (let [q (- 1 p) - n1 (inc n) - k (range n1) - pk (take n1 (iterate #(* p %) 1)) - ql (reverse (take n1 (iterate #(* q %) 1))) - f (bc n)] - (into {} (map vector k (map * f pk ql))))) - -(defn make-distribution - "Returns the distribution in which each element x of the collection - has a probability proportional to (f x)" - [coll f] - (normalize (into {} (for [k coll] [k (f k)])))) - -(defn zipf - "Returns the Zipf distribution in which the numbers k=1..n have - probabilities proportional to 1/k^s." - [s n] - (make-distribution (range 1 (inc n)) #(/ (java.lang.Math/pow % s)))) - -(defn certainly - "Returns a distribution in which the single value v has probability 1." - [v] - {v 1}) - -(with-monad dist-m - - (defn join-with - "Returns the distribution of (f x y) with x from dist1 and y from dist2." - [f dist1 dist2] - ((m-lift 2 f) dist1 dist2)) - -) - -(with-monad cond-dist-m - (defn cond-prob - "Returns the conditional probability for the values in dist that satisfy - the predicate pred." - [pred dist] - (normalize-cond - (domonad - [v dist - :when (pred v)] - v)))) - -; Select (with equal probability) N items from a sequence - -(defn- nth-and-rest [n xs] - "Return a list containing the n-th value of xs and the sequence - obtained by removing the n-th value from xs." - (let [[h t] (split-at n xs)] - (list (first t) (concat h (rest t))))) - -(with-monad dist-m - - (defn- select-n [n xs] - (letfn [(select-1 [[s xs]] - (uniform (for [i (range (count xs))] - (let [[nth rest] (nth-and-rest i xs)] - (list (cons nth s) rest)))))] - ((m-chain (replicate n select-1)) (list '() xs)))) - - (defn select [n xs] - "Return the distribution for all possible ordered selections of n elements - out of xs." - ((m-lift 1 first) (select-n n xs))) - -) - -; Find the probability that a given predicate is satisfied - -(defn prob - "Return the probability that the predicate pred is satisfied in the - distribution dist, i.e. the sum of the probabilities of the values - that satisfy pred." - [pred dist] - (apply + (for [[x p] dist :when (pred x)] p))) - diff --git a/src/clojure/contrib/probabilities/monte_carlo.clj b/src/clojure/contrib/probabilities/monte_carlo.clj deleted file mode 100644 index e3bc0f7e..00000000 --- a/src/clojure/contrib/probabilities/monte_carlo.clj +++ /dev/null @@ -1,240 +0,0 @@ -;; Monte-Carlo algorithms - -;; by Konrad Hinsen -;; last updated May 3, 2009 - -;; Copyright (c) Konrad Hinsen, 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. - -(ns - #^{:author "Konrad Hinsen" - :doc "Monte-Carlo method support - - Monte-Carlo methods transform an input random number stream - (usually having a continuous uniform distribution in the - interval [0, 1)) into a random number stream whose distribution - satisfies certain conditions (usually the expectation value - is equal to some desired quantity). They are thus - transformations from one probability distribution to another one. - - This library represents a Monte-Carlo method by a function that - takes as input the state of a random number stream with - uniform distribution (see - clojure.contrib.probabilities.random-numbers) and returns a - vector containing one sample value of the desired output - distribution and the final state of the input random number - stream. Such functions are state monad values and can be - composed using operations defined in clojure.contrib.monads."} - clojure.contrib.probabilities.monte-carlo - (:refer-clojure :exclude (deftype)) - (:use [clojure.contrib.macros :only (const)]) - (:use [clojure.contrib.types :only (deftype)]) - (:use [clojure.contrib.stream-utils :only (defstream stream-next)]) - (:use [clojure.contrib.monads - :only (with-monad state-m m-lift m-seq m-fmap)]) - (:require [clojure.contrib.generic.arithmetic :as ga]) - (:require [clojure.contrib.accumulators :as acc])) - -;; Random number transformers and random streams -;; -;; A random number transformer is a function that takes a random stream -;; state as input and returns the next value from the transformed stream -;; plus the new state of the input stream. Random number transformers -;; are thus state monad values. -;; -;; Distributions are implemented as random number transformers that -;; transform a uniform distribution in the interval [0, 1) to the -;; desired distribution. Composition of such distributions allows -;; the realization of any kind of Monte-Carlo algorithm. The result -;; of such a composition is always again a distribution. -;; -;; Random streams are defined by a random number transformer and an -;; input random number stream. If the randon number transformer represents -;; a distribution, the input stream must have a uniform distribution -;; in the interval [0, 1). - -; Random stream definition -(deftype ::random-stream random-stream - "Define a random stream by a distribution and the state of a - random number stream with uniform distribution in [0, 1)." - {:arglists '([distribution random-stream-state])} - (fn [d rs] (list d rs))) - -(defstream ::random-stream - [[d rs]] - (let [[r nrs] (d rs)] - [r (random-stream d nrs)])) - -; Rejection of values is used in the construction of distributions -(defn reject - "Return the distribution that results from rejecting the values from - dist that do not satisfy predicate p." - [p dist] - (fn [rs] - (let [[r nrs] (dist rs)] - (if (p r) - (recur nrs) - [r nrs])))) - -; Draw a value from a discrete distribution given as a map from -; values to probabilities. -; (see clojure.contrib.probabilities.finite-distributions) -(with-monad state-m - (defn discrete - "A discrete distribution, defined by a map dist mapping values - to probabilities. The sum of probabilities must be one." - [dist] - (letfn [(pick-at-level [l dist-items] - (let [[[x p] & rest-dist] dist-items] - (if (> p l) - x - (recur (- l p) rest-dist))))] - (m-fmap #(pick-at-level % (seq dist)) stream-next)))) - -; Uniform distribution in an finite half-open interval -(with-monad state-m - (defn interval - [a b] - "Transform a sequence of uniform random numbers in the interval [0, 1) - into a sequence of uniform random numbers in the interval [a, b)." - (let [d (- b a) - f (if (zero? a) - (if (= d 1) - identity - (fn [r] (* d r))) - (if (= d 1) - (fn [r] (+ a r)) - (fn [r] (+ a (* d r)))))] - (m-fmap f stream-next)))) - -; Normal (Gaussian) distribution -(defn normal - "Transform a sequence urs of uniform random number in the interval [0, 1) - into a sequence of normal random numbers with mean mu and standard - deviation sigma." - [mu sigma] - ; This function implements the Kinderman-Monahan ratio method: - ; A.J. Kinderman & J.F. Monahan - ; Computer Generation of Random Variables Using the Ratio of Uniform Deviates - ; ACM Transactions on Mathematical Software 3(3) 257-260, 1977 - (fn [rs] - (let [[u1 rs] (stream-next rs) - [u2* rs] (stream-next rs) - u2 (- 1. u2*) - s (const (* 4 (/ (. Math exp (- 0.5)) (. Math sqrt 2.)))) - z (* s (/ (- u1 0.5) u2)) - zz (+ (* 0.25 z z) (. Math log u2))] - (if (> zz 0) - (recur rs) - [(+ mu (* sigma z)) rs])))) - -; Lognormal distribution -(with-monad state-m - (defn lognormal - "Transform a sequence of uniform random numbesr in the interval [0, 1) - into a sequence of lognormal random numbers with mean mu and standard - deviation sigma." - [mu sigma] - (m-fmap #(. Math exp %) (normal mu sigma)))) - -; Exponential distribution -(with-monad state-m - (defn exponential - "Transform a sequence of uniform random numbers in the interval [0, 1) - into a sequence of exponential random numbers with parameter lambda." - [lambda] - (when (<= lambda 0) - (throw (IllegalArgumentException. - "exponential distribution requires a positive argument"))) - (let [neg-inv-lambda (- (/ lambda)) - ; remove very small numbers to prevent log from returning -Infinity - not-too-small (reject #(< % 1e-323) stream-next)] - (m-fmap #(* (. Math log %) neg-inv-lambda) not-too-small)))) - -; Another implementation of the normal distribution. It uses the -; Box-Muller transform, but discards one of the two result values -; at each cycle because the random number transformer interface cannot -; handle two outputs at the same time. -(defn normal-box-muller - "Transform a sequence of uniform random numbers in the interval [0, 1) - into a sequence of normal random numbers with mean mu and standard - deviation sigma." - [mu sigma] - (fn [rs] - (let [[u1 rs] (stream-next rs) - [u2 rs] (stream-next rs) - v1 (- (* 2.0 u1) 1.0) - v2 (- (* 2.0 u2) 1.0) - s (+ (* v1 v1) (* v2 v2)) - ls (. Math sqrt (/ (* -2.0 (. Math log s)) s)) - x1 (* v1 ls) - x2 (* v2 ls)] - (if (or (>= s 1) (= s 0)) - (recur rs) - [x1 rs])))) - -; Finite samples from a distribution -(with-monad state-m - - (defn sample - "Return the distribution of samples of length n from the - distribution dist" - [n dist] - (m-seq (replicate n dist))) - - (defn sample-reduce - "Returns the distribution of the reduction of f over n samples from the - distribution dist." - ([f n dist] - (if (zero? n) - (m-result (f)) - (let [m-f (m-lift 2 f) - sample (replicate n dist)] - (reduce m-f sample)))) - ([f val n dist] - (let [m-f (m-lift 2 f) - m-val (m-result val) - sample (replicate n dist)] - (reduce m-f m-val sample)))) - - (defn sample-sum - "Return the distribution of the sum over n samples from the - distribution dist." - [n dist] - (sample-reduce ga/+ n dist)) - - (defn sample-mean - "Return the distribution of the mean over n samples from the - distribution dist" - [n dist] - (let [div-by-n (m-lift 1 #(ga/* % (/ n)))] - (div-by-n (sample-sum n dist)))) - - (defn sample-mean-variance - "Return the distribution of the mean-and-variance (a vector containing - the mean and the variance) over n samples from the distribution dist" - [n dist] - (let [extract (m-lift 1 (fn [mv] [(:mean mv) (:variance mv)]))] - (extract (sample-reduce acc/add acc/empty-mean-variance n dist)))) - -) - -; Uniform distribution inside an n-sphere -(with-monad state-m - (defn n-sphere - "Return a uniform distribution of n-dimensional vectors inside an - n-sphere of radius r." - [n r] - (let [box-dist (sample n (interval (- r) r)) - sq #(* % %) - r-sq (sq r) - vec-sq #(apply + (map sq %)) - sphere-dist (reject #(> (vec-sq %) r-sq) box-dist) - as-vectors (m-lift 1 vec)] - (as-vectors sphere-dist)))) - diff --git a/src/clojure/contrib/probabilities/random_numbers.clj b/src/clojure/contrib/probabilities/random_numbers.clj deleted file mode 100644 index bc21769b..00000000 --- a/src/clojure/contrib/probabilities/random_numbers.clj +++ /dev/null @@ -1,63 +0,0 @@ -;; Random number generators - -;; by Konrad Hinsen -;; last updated May 3, 2009 - -;; Copyright (c) Konrad Hinsen, 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. - -(ns - #^{:author "Konrad Hinsen" - :doc "Random number streams - - This library provides random number generators with a common - stream interface. They all produce pseudo-random numbers that are - uniformly distributed in the interval [0, 1), i.e. 0 is a - possible value but 1 isn't. For transformations to other - distributions, see clojure.contrib.probabilities.monte-carlo. - - At the moment, the only generator provided is a rather simple - linear congruential generator."} - clojure.contrib.probabilities.random-numbers - (:refer-clojure :exclude (deftype)) - (:use [clojure.contrib.types :only (deftype)]) - (:use [clojure.contrib.stream-utils :only (defstream)]) - (:use [clojure.contrib.def :only (defvar)])) - -;; Linear congruential generator -;; http://en.wikipedia.org/wiki/Linear_congruential_generator - -(deftype ::lcg lcg - "Create a linear congruential generator" - {:arglists '([modulus multiplier increment seed])} - (fn [modulus multiplier increment seed] - {:m modulus :a multiplier :c increment :seed seed}) - (fn [s] (map s (list :m :a :c :seed)))) - -(defstream ::lcg - [lcg-state] - (let [{m :m a :a c :c seed :seed} lcg-state - value (/ (float seed) (float m)) - new-seed (rem (+ c (* a seed)) m)] - [value (assoc lcg-state :seed new-seed)])) - -;; A generator based on Clojure's built-in rand function -;; (and thus random from java.lang.Math) -;; Note that this generator uses an internal mutable state. -;; -;; The state is *not* stored in the stream object and can thus -;; *not* be restored! - -(defvar rand-stream (with-meta 'rand {:type ::rand-stream}) - "A random number stream based on clojure.core/rand. Note that this - generator uses an internal mutable state. The state is thus not stored - in the stream object and cannot be restored.") - -(defstream ::rand-stream - [dummy-state] - [(rand) dummy-state]) diff --git a/src/clojure/contrib/profile.clj b/src/clojure/contrib/profile.clj deleted file mode 100644 index bd26ddfa..00000000 --- a/src/clojure/contrib/profile.clj +++ /dev/null @@ -1,110 +0,0 @@ -;;; profile.clj: simple code profiling & timing - -;; by Stuart Sierra, http://stuartsierra.com/ -;; May 9, 2009 - -;; Copyright (c) Stuart Sierra, 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. - - -(ns #^{:author "Stuart Sierra" - :doc "Simple code profiling & timing measurement. - -Wrap any section of code in the prof macro, giving it a name, like this: - - (defn my-function [x y] - (let [sum (prof :addition (+ x y)) - product (prof :multiplication (* x y))] - [sum product])) - -The run your code in the profile macro, like this: - - (profile (dotimes [i 10000] (my-function 3 4))) - -Which prints a report for each named section of code: - - Name mean min max count sum - addition 265 0 37000 10000 2655000 -multiplication 274 0 53000 10000 2747000 - -Times are measured in nanoseconds, to the maximum precision available -under the JVM. See the function documentation for more details. -"} - clojure.contrib.profile) - -(def *profile-data* nil) - -(def #^{:doc "Set this to false before loading/compiling to omit -profiling code."} *enable-profiling* true) - -(defmacro prof - "If *enable-profiling* is true, wraps body in profiling code. - Returns the result of body. Profile timings will be stored in - *profile-data* using name, which must be a keyword, as the key. - Timings are measured with System/nanoTime." - [name & body] - (assert (keyword? name)) - (if *enable-profiling* - `(if *profile-data* - (let [start-time# (System/nanoTime) - value# (do ~@body) - elapsed# (- (System/nanoTime) start-time#)] - (swap! *profile-data* assoc ~name - (conj (get @*profile-data* ~name) elapsed#)) - value#) - ~@body) - `(do ~@body))) - -(defmacro with-profile-data - "Executes body with *profile-data* bound to an atom of a new map. - Returns the raw profile data as a map. Keys in the map are profile - names (keywords), and values are lists of elapsed time, in - nanoseconds." - [& body] - `(binding [*profile-data* (atom {})] - ~@body - @*profile-data*)) - -(defn summarize - "Takes the raw data returned by with-profile-data and returns a map - from names to summary statistics. Each value in the map will look - like: - - {:mean ..., :min ..., :max ..., :count ..., :sum ...} - - :mean, :min, and :max are how long the profiled section took to run, - in nanoseconds. :count is the total number of times the profiled - section was executed. :sum is the total amount of time spent in the - profiled section, in nanoseconds." - [profile-data] - (reduce (fn [m [k v]] - (let [cnt (count v) - sum (reduce + v)] - (assoc m k {:mean (int (/ sum cnt)) - :min (apply min v) - :max (apply max v) - :count cnt - :sum sum}))) - {} profile-data)) - -(defn print-summary - "Prints a table of the results returned by summarize." - [profile-summary] - (let [name-width (apply max (map (comp count name) (keys profile-summary))) - fmt-string (str "%" name-width "s %8d %8d %8d %8d %8d%n")] - (printf (.replace fmt-string \d \s) - "Name" "mean" "min" "max" "count" "sum") - (doseq [k (sort (keys profile-summary))] - (let [v (get profile-summary k)] - (printf fmt-string (name k) (:mean v) (:min v) (:max v) (:count v) (:sum v)))))) - -(defmacro profile - "Runs body with profiling enabled, then prints a summary of - results. Returns nil." - [& body] - `(print-summary (summarize (with-profile-data (do ~@body))))) diff --git a/src/clojure/contrib/prxml.clj b/src/clojure/contrib/prxml.clj deleted file mode 100755 index a2362223..00000000 --- a/src/clojure/contrib/prxml.clj +++ /dev/null @@ -1,166 +0,0 @@ -;;; prxml.clj -- compact syntax for generating XML - -;; by Stuart Sierra, http://stuartsierra.com/ -;; March 29, 2009 - -;; Copyright (c) 2009 Stuart Sierra. 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. - - -;; Change Log -;; -;; March 29, 2009: added *prxml-indent* -;; -;; January 4, 2009: initial version - - -;; See function "prxml" at the bottom of this file for documentation. - - -(ns - #^{:author "Stuart Sierra", - :doc "Compact syntax for generating XML. See the documentation of \"prxml\" -for details."} - clojure.contrib.prxml - (:use [clojure.contrib.lazy-xml :only (escape-xml)])) - -(def - #^{:doc "If true, empty tags will have a space before the closing />"} - *html-compatible* false) - -(def - #^{:doc "The number of spaces to indent sub-tags. nil for no indent - and no extra line-breaks."} - *prxml-indent* nil) - -(defn- namestr [x] - (if (or (symbol? x) (keyword? x)) (name x) (str x))) - -(def #^{:private true} *prxml-tag-depth* 0) - -(def #^{:private true} print-xml) ; forward declaration - -(defn- prxml-attribute [name value] - (print " ") - (print (namestr name)) - (print "=\"") - (print (escape-xml (str value))) - (print "\"")) - -(defmulti #^{:private true} print-xml-tag (fn [tag attrs content] tag)) - -(defmethod print-xml-tag :raw! [tag attrs contents] - (doseq [c contents] (print c))) - -(defmethod print-xml-tag :comment! [tag attrs contents] - (print "<!-- ") - (doseq [c contents] (print c)) - (print " -->")) - -(defmethod print-xml-tag :decl! [tag attrs contents] - (let [attrs (merge {:version "1.0" :encoding "UTF-8"} - attrs)] - ;; Must enforce ordering of pseudo-attributes: - (print "<?xml version=\"") - (print (:version attrs)) - (print "\" encoding=\"") - (print (:encoding attrs)) - (print "\"") - (when (:standalone attrs) - (print " standalone=\"") - (print (:standalone attrs)) - (print "\"")) - (print "?>"))) - -(defmethod print-xml-tag :cdata! [tag attrs contents] - (print "<![CDATA[") - (doseq [c contents] (print c)) - (print "]]>")) - -(defmethod print-xml-tag :doctype! [tag attrs contents] - (print "<!DOCTYPE ") - (doseq [c contents] (print c)) - (print ">")) - -(defmethod print-xml-tag :default [tag attrs contents] - (let [tag-name (namestr tag)] - (when *prxml-indent* - (newline) - (dotimes [n (* *prxml-tag-depth* *prxml-indent*)] (print " "))) - (print "<") - (print tag-name) - (doseq [[name value] attrs] - (prxml-attribute name value)) - (if (seq contents) - (do ;; not an empty tag - (print ">") - (if (every? string? contents) - ;; tag only contains strings: - (do (doseq [c contents] (print-xml c)) - (print "</") (print tag-name) (print ">")) - ;; tag contains sub-tags: - (do (binding [*prxml-tag-depth* (inc *prxml-tag-depth*)] - (doseq [c contents] (print-xml c))) - (when *prxml-indent* - (newline) - (dotimes [n (* *prxml-tag-depth* *prxml-indent*)] (print " "))) - (print "</") (print tag-name) (print ">")))) - ;; empty tag: - (print (if *html-compatible* " />" "/>"))))) - - -(defmulti #^{:private true} print-xml class) - -(defmethod print-xml clojure.lang.IPersistentVector [x] - (let [[tag & contents] x - [attrs content] (if (map? (first contents)) - [(first contents) (rest contents)] - [{} contents])] - (print-xml-tag tag attrs content))) - -(defmethod print-xml clojure.lang.ISeq [x] - ;; Recurse into sequences, so we can use (map ...) inside prxml. - (doseq [c x] (print-xml c))) - -(defmethod print-xml clojure.lang.Keyword [x] - (print-xml-tag x {} nil)) - -(defmethod print-xml String [x] - (print (escape-xml x))) - -(defmethod print-xml nil [x]) - -(defmethod print-xml :default [x] - (print x)) - - -(defn prxml - "Print XML to *out*. Vectors become XML tags: the first item is the - tag name; optional second item is a map of attributes. - - Sequences are processed recursively, so you can use map and other - sequence functions inside prxml. - - (prxml [:p {:class \"greet\"} [:i \"Ladies & gentlemen\"]]) - ; => <p class=\"greet\"><i>Ladies & gentlemen</i></p> - - PSEUDO-TAGS: some keywords have special meaning: - - :raw! do not XML-escape contents - :comment! create an XML comment - :decl! create an XML declaration, with attributes - :cdata! create a CDATA section - :doctype! create a DOCTYPE! - - (prxml [:p [:raw! \"<i>here & gone</i>\"]]) - ; => <p><i>here & gone</i></p> - - (prxml [:decl! {:version \"1.1\"}]) - ; => <?xml version=\"1.1\" encoding=\"UTF-8\"?>" - [& args] - (doseq [arg args] (print-xml arg))) diff --git a/src/clojure/contrib/repl_ln.clj b/src/clojure/contrib/repl_ln.clj deleted file mode 100644 index 7b8ef052..00000000 --- a/src/clojure/contrib/repl_ln.clj +++ /dev/null @@ -1,274 +0,0 @@ -;; Copyright (c) Stephen C. Gilardi. 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. -;; -;; A repl with that provides support for lines and line numbers in the -;; input stream. -;; -;; scgilardi (gmail) -;; Created 28 November 2008 - -(ns - #^{:author "Stephen C. Gilardi", - :doc "A repl with that provides support for lines and line numbers in the - input stream."} - clojure.contrib.repl-ln - (:gen-class) - (:import (clojure.lang Compiler LineNumberingPushbackReader RT Var) - (java.io InputStreamReader OutputStreamWriter PrintWriter) - java.util.Date) - (:require clojure.main) - (:use [clojure.contrib.def - :only (defmacro- defonce- defstruct- defvar-)])) - -;; Private - -(declare repl) - -(defstruct- repl-info - :name :started :name-fmt :prompt-fmt :serial :thread :depth) - -(defvar- +name-formats+ - {"%S" "%1$d" "%T" "%2$d" "%D" "%3$d"} - "For set-name, maps our dynamic value codes to arg positions in - the call to format in repl-name") - -(defvar- +prompt-formats+ - {"%S" "%1$d" "%T" "%2$d" "%D" "%3$d" "%L" "%4$d" "%N" "%5$s"} - "For set-prompt, maps our dynamic value codes to arg positions in - the call to format in repl-prompt") - -(defvar- +info-format+ - ["Name: %s" - "Started: %s" - "Name-fmt: \"%s\"" - "Prompt-fmt: \"%s\"" - "Serial: %d" - "Thread: %d" - "Depth: %d" - "Line: %d"]) - -(defvar- +info-defaults+ - (struct-map repl-info - :name-fmt "repl-%S" - :prompt-fmt "%S:%L %N=> " - :depth 0) - "Default/root values for repl info") - -(defonce- *serial-number* (atom 0) - "Serial number counter") - -(defonce- *info* +info-defaults+ - "Public info for this repl") - -(defonce- *private* {} - "Private info for this repl") - -(defmacro- update - "Replaces the map thread-locally bound to map-var with a copy that - includes updated and/or new values from keys and vals." - [map-var & key-vals] - `(set! ~map-var (assoc ~map-var ~@key-vals))) - -(defn- repl-name - "Returns the repl name based on this repl's name-fmt" - [] - (let [{:keys [name-fmt]} *private* - {:keys [serial thread depth]} *info*] - (format name-fmt serial thread depth))) - -(defn- prompt-hook - [] - (let [prompt (*private* :prompt)] - (var-set Compiler/LINE (.getLineNumber *in*)) - (prompt))) - -(defn- process-inits - "Processes initial pairs of args of the form: - - -i filepath, or - --init filepath - - by loading the referenced files, then accepts an optional terminating arg - of the form: - - -r, or - --repl - - Returns a seq of any remaining args." - [args] - (loop [[init filename & more :as args] args] - (if (#{"-i" "--init"} init) - (do - (clojure.main/load-script filename) - (recur more)) - (if (#{"-r" "--repl"} init) - (rest args) - args)))) - -(defn- process-command-line - "Args are strings passed in from the command line. Loads any requested - init files and binds *command-line-args* to a seq of the remaining args" - [args] - (set! *command-line-args* (process-inits args))) - -(defn stream-repl - "Repl entry point that provides convenient overriding of input, output, - and err streams via sequential keyword-value pairs. Default values - for :in, :out, and :err are streams associated with System/in, - System/out, and System/err using UTF-8 encoding. Also supports all the - options provided by clojure.contrib.repl-ln/repl." - [& options] - (let [enc RT/UTF8 - {:keys [in out err] - :or {in (LineNumberingPushbackReader. - (InputStreamReader. System/in enc)) - out (OutputStreamWriter. System/out enc) - err (PrintWriter. (OutputStreamWriter. System/err enc))}} - (apply hash-map options)] - (binding [*in* in *out* out *err* err] - (apply repl options)))) - -(defn- -main - "Main entry point, starts a repl enters the user namespace and processes - command line args." - [& args] - (repl :init - (fn [] - (println "Clojure" (clojure-version)) - (in-ns 'user) - (process-command-line args)))) - -;; Public - -(defn repl-prompt - "Returns the current repl prompt based on this repl's prompt-fmt" - [] - (let [{:keys [prompt-fmt]} *private* - {:keys [serial thread depth]} *info* - line (.getLineNumber *in*) - namespace (ns-name *ns*)] - (format prompt-fmt serial thread depth line namespace))) - -(defn set-repl-name - "Sets the repl name format to the string name-fmt. Include the following - codes in the name to make the corresponding dynamic values part of it: - - %S - repl serial number - %T - thread id - %D - nesting depth in this thread - - With no arguments, resets the repl name to its default: \"repl-%S\"" - ([] - (set-repl-name (+info-defaults+ :name-fmt))) - ([name-fmt] - (update *info* :name-fmt name-fmt) - (loop [[[code fmt] & more] (seq +name-formats+) - name-fmt name-fmt] - (if code - (recur more (.replace name-fmt code fmt)) - (update *private* :name-fmt name-fmt))) - (let [name (repl-name)] - (update *info* :name name) - (var-set Compiler/SOURCE name)) - nil)) - -(defn set-repl-prompt - "Sets the repl prompt. Include the following codes in the prompt to make - the corresponding dynamic values part of it: - - %S - repl serial number - %T - thread id - %D - nesting depth in this thread - %L - input line number - %N - namespace name - - With no arguments, resets the repl pompt to its default: \"%S:%L %N=> \"" - ([] - (set-repl-prompt (+info-defaults+ :prompt-fmt))) - ([prompt-fmt] - (update *info* :prompt-fmt prompt-fmt) - (loop [[[code fmt] & more] (seq +prompt-formats+) - prompt-fmt prompt-fmt] - (if code - (recur more (.replace prompt-fmt code fmt)) - (update *private* :prompt-fmt prompt-fmt))) - nil)) - -(defn repl-info - "Returns a map of info about the current repl" - [] - (let [line (.getLineNumber *in*)] - (assoc *info* :line line))) - -(defn print-repl-info - "Prints info about the current repl" - [] - (let [{:keys [name started name-fmt prompt-fmt serial thread depth line]} - (repl-info)] - (printf - (apply str (interleave +info-format+ (repeat "\n"))) - name started name-fmt prompt-fmt serial thread depth line))) - -(defn repl - "A repl that supports line numbers. For definitions and evaluations made - at the repl, the repl-name and line number will be reported as the - origin. Use set-repl-name and set-repl-prompt to customize the repl name - and prompt. This repl supports all of the keyword arguments documented - for clojure.main/repl with the following change and additions: - - - :prompt has a new default - default: #(clojure.core/print (repl-prompt)) - - - :name-fmt, Name format string - default: the name-fmt of the parent repl, or \"repl-%S\" - - - :prompt-fmt, Prompt format string - default: the prompt-fmt of the parent repl, or \"%S:%L %N=> \"" - [& options] - (let [{:keys [init need-prompt prompt flush read eval print caught - name-fmt prompt-fmt] - :or {init #() - need-prompt (if (instance? LineNumberingPushbackReader *in*) - #(.atLineStart *in*) - #(identity true)) - prompt #(clojure.core/print (repl-prompt)) - flush flush - read clojure.main/repl-read - eval eval - print prn - caught clojure.main/repl-caught - name-fmt (*info* :name-fmt) - prompt-fmt (*info* :prompt-fmt)}} - (apply hash-map options)] - (try - (Var/pushThreadBindings - {Compiler/SOURCE (var-get Compiler/SOURCE) - Compiler/LINE (var-get Compiler/LINE) - (var *info*) *info* - (var *private*) {}}) - (update *info* - :started (Date.) - :serial (swap! *serial-number* inc) - :thread (.getId (Thread/currentThread)) - :depth (inc (*info* :depth))) - (update *private* - :prompt prompt) - (set-repl-name name-fmt) - (set-repl-prompt prompt-fmt) - (clojure.main/repl - :init init - :need-prompt need-prompt - :prompt prompt-hook - :flush flush - :read read - :eval eval - :print print - :caught caught) - (finally - (Var/popThreadBindings) - (prn))))) diff --git a/src/clojure/contrib/repl_utils.clj b/src/clojure/contrib/repl_utils.clj deleted file mode 100644 index 30c483ca..00000000 --- a/src/clojure/contrib/repl_utils.clj +++ /dev/null @@ -1,195 +0,0 @@ -; Copyright (c) Chris Houser, Dec 2008. All rights reserved. -; The use and distribution terms for this software are covered by the -; Common Public License 1.0 (http://opensource.org/licenses/cpl.php) -; which can be found in the file CPL.TXT 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. - -; Utilities meant to be used interactively at the REPL - -(ns - #^{:author "Chris Houser, Christophe Grand, Stephen Gilardi", - :doc "Utilities meant to be used interactively at the REPL"} - clojure.contrib.repl-utils - (:import (java.io File LineNumberReader InputStreamReader PushbackReader) - (java.lang.reflect Modifier Method Constructor) - (clojure.lang RT Compiler Compiler$C)) - (:use [clojure.contrib.seq-utils :only (indexed)] - [clojure.contrib.javadoc.browse :only (browse-url)] - [clojure.contrib.str-utils :only (str-join re-sub re-partition)])) - -;; ---------------------------------------------------------------------- -;; Examine Java classes - -(defn- sortable [t] - (apply str (map (fn [[a b]] (str a (format "%04d" (Integer. b)))) - (partition 2 (concat (re-partition #"\d+" t) [0]))))) - -(defn- param-str [m] - (str " (" (str-join - "," (map (fn [[c i]] - (if (> i 3) - (str (.getSimpleName c) "*" i) - (str-join "," (replicate i (.getSimpleName c))))) - (reduce (fn [pairs y] (let [[x i] (peek pairs)] - (if (= x y) - (conj (pop pairs) [y (inc i)]) - (conj pairs [y 1])))) - [] (.getParameterTypes m)))) - ")")) - -(defn- member-details [m] - (let [static? (Modifier/isStatic (.getModifiers m)) - method? (instance? Method m) - ctor? (instance? Constructor m) - text (if ctor? - (str "<init>" (param-str m)) - (str - (when static? "static ") - (.getName m) " : " - (if method? - (str (.getSimpleName (.getReturnType m)) (param-str m)) - (str (.getSimpleName (.getType m))))))] - (assoc (bean m) - :sort-val [(not static?) method? (sortable text)] - :text text - :member m))) - -(defn show - "With one arg prints all static and instance members of x or (class x). - Each member is listed with a number which can be given as 'selector' - to return the member object -- the REPL will print more details for - that member. - - The selector also may be a string or regex, in which case only - members whose names match 'selector' as a case-insensitive regex - will be printed. - - Finally, the selector also may be a predicate, in which case only - members for which the predicate returns true will be printed. The - predicate will be passed a single argument, a map that includes the - :text that will be printed and the :member object itself, as well as - all the properies of the member object as translated by 'bean'. - - Examples: (show Integer) (show []) (show String 23) (show String \"case\")" - ([x] (show x (constantly true))) - ([x selector] - (let [c (if (class? x) x (class x)) - members (sort-by :sort-val - (map member-details - (concat (.getFields c) - (.getMethods c) - (.getConstructors c))))] - (if (number? selector) - (:member (nth members selector)) - (let [pred (if (ifn? selector) - selector - #(re-find (re-pattern (str "(?i)" selector)) (:name %)))] - (println "=== " (Modifier/toString (.getModifiers c)) c " ===") - (doseq [[i m] (indexed members)] - (when (pred m) - (printf "[%2d] %s\n" i (:text m))))))))) - -;; ---------------------------------------------------------------------- -;; Examine Clojure functions (Vars, really) - -(defn get-source - "Returns a string of the source code for the given symbol, if it can - find it. This requires that the symbol resolve to a Var defined in - a namespace for which the .clj is in the classpath. Returns nil if - it can't find the source. For most REPL usage, 'source' is more - convenient. - - Example: (get-source 'filter)" - [x] - (when-let [v (resolve x)] - (when-let [filepath (:file (meta v))] - (when-let [strm (.getResourceAsStream (RT/baseLoader) filepath)] - (with-open [rdr (LineNumberReader. (InputStreamReader. strm))] - (dotimes [_ (dec (:line (meta v)))] (.readLine rdr)) - (let [text (StringBuilder.) - pbr (proxy [PushbackReader] [rdr] - (read [] (let [i (proxy-super read)] - (.append text (char i)) - i)))] - (read (PushbackReader. pbr)) - (str text))))))) - -(defmacro source - "Prints the source code for the given symbol, if it can find it. - This requires that the symbol resolve to a Var defined in a - namespace for which the .clj is in the classpath. - - Example: (source filter)" - [n] - `(println (or (get-source '~n) (str "Source not found")))) - -;; ---------------------------------------------------------------------- -;; Handle Ctrl-C keystrokes - -(def #^{:doc "Threads to stop when Ctrl-C is pressed. See 'add-break-thread!'"} - break-threads (atom {})) - -(let [first-time (atom true)] - (defn start-handling-break - "Register INT signal handler. After calling this, Ctrl-C will cause - all break-threads to be stopped. See 'add-break-thread!'" - [] - (when (= :need-init - (swap! first-time - {:need-init false, false false, true :need-init})) - (sun.misc.Signal/handle - (sun.misc.Signal. "INT") - (proxy [sun.misc.SignalHandler] [] - (handle [sig] - (let [exc (Exception. (str sig))] - (doseq [tref (vals @break-threads) :when (.get tref)] - (.stop (.get tref) exc))))))))) - -(defn add-break-thread! - "Add the given thread to break-threads so that it will be stopped - any time the user presses Ctrl-C. Calls start-handling-break for - you. Adds the current thread if none is given." - ([] (add-break-thread! (Thread/currentThread))) - ([t] - (start-handling-break) - (let [tref (java.lang.ref.WeakReference. t)] - (swap! break-threads assoc (.getId t) tref)))) - -;; ---------------------------------------------------------------------- -;; Compiler hooks - -(defn expression-info - "Uses the Clojure compiler to analyze the given s-expr. Returns - a map with keys :class and :primitive? indicating what the compiler - concluded about the return value of the expression. Returns nil if - not type info can be determined at compile-time. - - Example: (expression-info '(+ (int 5) (float 10))) - Returns: {:class float, :primitive? true}" - [expr] - (let [fn-ast (Compiler/analyze Compiler$C/EXPRESSION `(fn [] ~expr)) - expr-ast (.body (first (.methods fn-ast)))] - (when (.hasJavaClass expr-ast) - {:class (.getJavaClass expr-ast) - :primitive? (.isPrimitive (.getJavaClass expr-ast))}))) - -;; ---------------------------------------------------------------------- -;; scgilardi at gmail - -(defn run* - "Loads the specified namespace and invokes its \"main\" function with - optional args." - [ns-sym & args] - (require ns-sym :reload-all) - (apply (ns-resolve ns-sym 'main) args)) - -(defmacro run - "Loads the specified namespace and invokes its \"main\" function with - optional args. ns-name is not evaluated." - [ns-name & args] - `(run* '~ns-name ~@args)) - - -(load "repl_utils/javadoc") diff --git a/src/clojure/contrib/repl_utils/javadoc.clj b/src/clojure/contrib/repl_utils/javadoc.clj deleted file mode 100644 index 32551340..00000000 --- a/src/clojure/contrib/repl_utils/javadoc.clj +++ /dev/null @@ -1,83 +0,0 @@ -; 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)))) diff --git a/src/clojure/contrib/seq_utils.clj b/src/clojure/contrib/seq_utils.clj deleted file mode 100644 index ad913f70..00000000 --- a/src/clojure/contrib/seq_utils.clj +++ /dev/null @@ -1,223 +0,0 @@ -;;; seq_utils.clj -- Sequence utilities for Clojure - -;; by Stuart Sierra, http://stuartsierra.com/ -;; last updated March 2, 2009 - -;; Copyright (c) Stuart Sierra, 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. - - -;; Change Log -;; -;; January 10, 2009 (Stuart Sierra): -;; -;; * BREAKING CHANGE: "includes?" now takes collection as first -;; argument. This is more consistent with Clojure collection -;; functions; see discussion at http://groups.google.com/group/clojure/browse_thread/thread/8b2c8dc96b39ddd7/a8866d34b601ff43 - - -(ns - #^{:author "Stuart Sierra (and others)", - :doc "Sequence utilities for Clojure"} - clojure.contrib.seq-utils - (:import (java.util.concurrent LinkedBlockingQueue TimeUnit) - (java.lang.ref WeakReference))) - - -;; 'flatten' written by Rich Hickey, -;; see http://groups.google.com/group/clojure/msg/385098fabfcaad9b -(defn flatten - "Takes any nested combination of sequential things (lists, vectors, - etc.) and returns their contents as a single, flat sequence. - (flatten nil) returns nil." - [x] - (filter (complement sequential?) - (rest (tree-seq sequential? seq x)))) - -(defn separate - "Returns a vector: - [ (filter f s), (filter (complement f) s) ]" - [f s] - [(filter f s) (filter (complement f) s)]) - -(defn includes? - "Returns true if coll contains something equal (with =) to x, - in linear time." - [coll x] - (if (some (fn [y] (= y x)) coll) - true false)) - -(defn indexed - "Returns a lazy sequence of [index, item] pairs, where items come - from 's' and indexes count up from zero. - - (indexed '(a b c d)) => ([0 a] [1 b] [2 c] [3 d])" - [s] - (map vector (iterate inc 0) s)) - -;; group-by written by Rich Hickey; -;; see http://paste.lisp.org/display/64190 -(defn group-by - "Returns a sorted map of the elements of coll keyed by the result of - f on each element. The value at each key will be a vector of the - corresponding elements, in the order they appeared in coll." - [f coll] - (reduce - (fn [ret x] - (let [k (f x)] - (assoc ret k (conj (get ret k []) x)))) - (sorted-map) coll)) - -;; partition-by originally written by Rich Hickey; -;; modified by Stuart Sierra -(defn partition-by - "Applies f to each value in coll, splitting it each time f returns - a new value. Returns a lazy seq of lazy seqs." - [f coll] - (when-let [s (seq coll)] - (let [fst (first s) - fv (f fst) - run (cons fst (take-while #(= fv (f %)) (rest s)))] - (lazy-seq - (cons run (partition-by f (drop (count run) s))))))) - -(defn frequencies - "Returns a map from distinct items in coll to the number of times - they appear." - [coll] - (reduce (fn [counts x] - (assoc counts x (inc (get counts x 0)))) - {} coll)) - -;; recursive sequence helpers by Christophe Grand -;; see http://clj-me.blogspot.com/2009/01/recursive-seqs.html -(defmacro rec-seq - "Similar to lazy-seq but binds the resulting seq to the supplied - binding-name, allowing for recursive expressions." - [binding-name & body] - `(let [s# (atom nil)] - (reset! s# (lazy-seq (let [~binding-name @s#] ~@body))))) - -(defmacro rec-cat - "Similar to lazy-cat but binds the resulting sequence to the supplied - binding-name, allowing for recursive expressions." - [binding-name & exprs] - `(rec-seq ~binding-name (lazy-cat ~@exprs))) - - -;; reductions by Chris Houser -;; see http://groups.google.com/group/clojure/browse_thread/thread/3edf6e82617e18e0/58d9e319ad92aa5f?#58d9e319ad92aa5f -(defn reductions - "Returns a lazy seq of the intermediate values of the reduction (as - per reduce) of coll by f, starting with init." - ([f coll] - (if (seq coll) - (rec-seq self (cons (first coll) (map f self (rest coll)))) - (cons (f) nil))) - ([f init coll] - (rec-seq self (cons init (map f self coll))))) - -(defn rotations - "Returns a lazy seq of all rotations of a seq" - [x] - (if (seq x) - (map - (fn [n _] - (lazy-cat (drop n x) (take n x))) - (iterate inc 0) x) - (list nil))) - -(defn partition-all - "Returns a lazy sequence of lists like clojure.core/partition, but may - include lists with fewer than n items at the end." - ([n coll] - (partition-all n n coll)) - ([n step coll] - (lazy-seq - (when-let [s (seq coll)] - (cons (take n s) (partition-all n step (drop step s))))))) - -(defn shuffle - "Return a random permutation of coll" - [coll] - (let [l (java.util.ArrayList. coll)] - (java.util.Collections/shuffle l) - (seq l))) - -(defn rand-elt - "Return a random element of this seq" - [s] - (nth s (rand-int (count s)))) - - -;; seq-on written by Konrad Hinsen -(defmulti seq-on - "Returns a seq on the object s. Works like the built-in seq but as - a multimethod that can have implementations for new classes and types." - {:arglists '([s])} - type) - -(defmethod seq-on :default - [s] - (seq s)) - - -(defn find-first - "Returns the first item of coll for which (pred item) returns logical true. - Consumes sequences up to the first match, will consume the entire sequence - and return nil if no match is found." - [pred coll] - (first (filter pred coll))) - -; based on work related to Rich Hickey's seque. -; blame Chouser for anything broken or ugly. -(defn fill-queue - "filler-func will be called in another thread with a single arg - 'fill'. filler-func may call fill repeatedly with one arg each - time which will be pushed onto a queue, blocking if needed until - this is possible. fill-queue will return a lazy seq of the values - filler-func has pushed onto the queue, blocking if needed until each - next element becomes available. filler-func's return value is ignored." - ([filler-func & optseq] - (let [opts (apply array-map optseq) - apoll (:alive-poll opts 1) - q (LinkedBlockingQueue. (:queue-size opts 1)) - NIL (Object.) ;nil sentinel since LBQ doesn't support nils - weak-target (Object.) - alive? (WeakReference. weak-target) - fill (fn fill [x] - (if (.get alive?) - (if (.offer q (if (nil? x) NIL x) apoll TimeUnit/SECONDS) - x - (recur x)) - (throw (Exception. "abandoned")))) - f (future - (try - (filler-func fill) - (finally - (.put q q))) ;q itself is eos sentinel - nil)] ; set future's value to nil - ((fn drain [] - weak-target ; force closing over this object - (lazy-seq - (let [x (.take q)] - (if (identical? x q) - @f ;will be nil, touch just to propagate errors - (cons (if (identical? x NIL) nil x) - (drain)))))))))) - -(defn positions - "Returns a lazy sequence containing the positions at which pred - is true for items in coll." - [pred coll] - (for [[idx elt] (indexed coll) :when (pred elt)] idx)) - - - - - diff --git a/src/clojure/contrib/server_socket.clj b/src/clojure/contrib/server_socket.clj deleted file mode 100644 index fad77076..00000000 --- a/src/clojure/contrib/server_socket.clj +++ /dev/null @@ -1,94 +0,0 @@ -;; Copyright (c) Craig McDaniel, 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. - -;; Server socket library - includes REPL on socket - -(ns - #^{:author "Craig McDaniel", - :doc "Server socket library - includes REPL on socket"} - clojure.contrib.server-socket - (:import (java.net InetAddress ServerSocket Socket SocketException) - (java.io InputStreamReader OutputStream OutputStreamWriter PrintWriter) - (clojure.lang LineNumberingPushbackReader)) - (:use [clojure.main :only (repl)])) - -(defn- on-thread [f] - (doto (Thread. #^Runnable f) - (.start))) - -(defn- close-socket [#^Socket s] - (when-not (.isClosed s) - (doto s - (.shutdownInput) - (.shutdownOutput) - (.close)))) - -(defn- accept-fn [#^Socket s connections fun] - (let [ins (.getInputStream s) - outs (.getOutputStream s)] - (on-thread #(do - (dosync (commute connections conj s)) - (try - (fun ins outs) - (catch SocketException e)) - (close-socket s) - (dosync (commute connections disj s)))))) - -(defstruct server-def :server-socket :connections) - -(defn- create-server-aux [fun #^ServerSocket ss] - (let [connections (ref #{})] - (on-thread #(when-not (.isClosed ss) - (try - (accept-fn (.accept ss) connections fun) - (catch SocketException e)) - (recur))) - (struct-map server-def :server-socket ss :connections connections))) - -(defn create-server - "Creates a server socket on port. Upon accept, a new thread is - created which calls: - - (fun input-stream output-stream) - - Optional arguments support specifying a listen backlog and binding - to a specific endpoint." - ([port fun backlog #^InetAddress bind-addr] - (create-server-aux fun (ServerSocket. port backlog bind-addr))) - ([port fun backlog] - (create-server-aux fun (ServerSocket. port backlog))) - ([port fun] - (create-server-aux fun (ServerSocket. port)))) - -(defn close-server [server] - (doseq [s @(:connections server)] - (close-socket s)) - (dosync (ref-set (:connections server) #{})) - (.close #^ServerSocket (:server-socket server))) - -(defn connection-count [server] - (count @(:connections server))) - -;;;; -;;;; REPL on a socket -;;;; - -(defn- socket-repl [ins outs] - (binding [*in* (LineNumberingPushbackReader. (InputStreamReader. ins)) - *out* (OutputStreamWriter. outs) - *err* (PrintWriter. #^OutputStream outs true)] - (repl))) - -(defn create-repl-server - "create a repl on a socket" - ([port backlog #^InetAddress bind-addr] - (create-server port socket-repl backlog bind-addr)) - ([port backlog] - (create-server port socket-repl backlog)) - ([port] - (create-server port socket-repl))) diff --git a/src/clojure/contrib/set.clj b/src/clojure/contrib/set.clj deleted file mode 100644 index 75c00018..00000000 --- a/src/clojure/contrib/set.clj +++ /dev/null @@ -1,47 +0,0 @@ -;; Copyright (c) Jason Wolfe. 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. -;; -;; set.clj -;; -;; Clojure functions for operating on sets (supplemental to clojure.set) -;; -;; jason at w01fe dot com -;; Created 2 Feb 2009 - -(ns - #^{:author "Jason Wolfe", - :doc "Clojure functions for operating on sets (supplemental to clojure.set)"} - clojure.contrib.set) - -(defn subset? - "Is set1 a subset of set2?" - [set1 set2] - {:tag Boolean} - (and (<= (count set1) (count set2)) - (every? set2 set1))) - -(defn superset? - "Is set1 a superset of set2?" - [set1 set2] - {:tag Boolean} - (and (>= (count set1) (count set2)) - (every? set1 set2))) - -(defn proper-subset? - "Is s1 a proper subset of s2?" - [set1 set2] - {:tag Boolean} - (and (< (count set1) (count set2)) - (every? set2 set1))) - -(defn proper-superset? - "Is s1 a proper superset of s2?" - [set1 set2] - {:tag Boolean} - (and (> (count set1) (count set2)) - (every? set1 set2))) diff --git a/src/clojure/contrib/shell_out.clj b/src/clojure/contrib/shell_out.clj deleted file mode 100644 index 5e0be467..00000000 --- a/src/clojure/contrib/shell_out.clj +++ /dev/null @@ -1,146 +0,0 @@ -; Copyright (c) Chris Houser, 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. - -; :dir and :env options added by Stuart Halloway - -; Conveniently launch a sub-process providing to its stdin and -; collecting its stdout - -(ns - #^{:author "Chris Houser", - :doc "Conveniently launch a sub-process providing to its stdin and -collecting its stdout"} - clojure.contrib.shell-out - (:import (java.io InputStreamReader OutputStreamWriter))) - -(def *sh-dir* nil) -(def *sh-env* nil) - -(defmacro with-sh-dir [dir & forms] - "Sets the directory for use with sh, see sh for details." - `(binding [*sh-dir* ~dir] - ~@forms)) - -(defmacro with-sh-env [env & forms] - "Sets the environment for use with sh, see sh for details." - `(binding [*sh-env* ~env] - ~@forms)) - -(defn- stream-seq - "Takes an InputStream and returns a lazy seq of integers from the stream." - [stream] - (take-while #(>= % 0) (repeatedly #(.read stream)))) - -(defn- aconcat - "Concatenates arrays of given type." - [type & xs] - (let [target (make-array type (apply + (map count xs)))] - (loop [i 0 idx 0] - (when-let [a (nth xs i nil)] - (System/arraycopy a 0 target idx (count a)) - (recur (inc i) (+ idx (count a))))) - target)) - -(defn- parse-args - "Takes a seq of 'sh' arguments and returns a map of option keywords - to option values." - [args] - (loop [[arg :as args] args opts {:cmd [] :out "UTF-8" :dir *sh-dir* :env *sh-env*}] - (if-not args - opts - (if (keyword? arg) - (recur (nnext args) (assoc opts arg (second args))) - (recur (next args) (update-in opts [:cmd] conj arg)))))) - -(defn- as-env-key [arg] - "Helper so that callers can use symbols, keywords, or strings - when building an environment map." - (cond - (symbol? arg) (name arg) - (keyword? arg) (name arg) - (string? arg) arg)) - -(defn- as-file [arg] - "Helper so that callers can pass a String for the :dir to sh." - (cond - (string? arg) (java.io.File. arg) - (nil? arg) nil - (instance? java.io.File arg) arg)) - -(defn- as-env-string [arg] - "Helper so that callers can pass a Clojure map for the :env to sh." - (cond - (nil? arg) nil - (map? arg) (into-array String (map (fn [[k v]] (str (as-env-key k) "=" v)) arg)) - true arg)) - - -(defn sh - "Passes the given strings to Runtime.exec() to launch a sub-process. - - Options are - - :in may be given followed by a String specifying text to be fed to the - sub-process's stdin. - :out option may be given followed by :bytes or a String. If a String - is given, it will be used as a character encoding name (for - example \"UTF-8\" or \"ISO-8859-1\") to convert the - sub-process's stdout to a String which is returned. - If :bytes is given, the sub-process's stdout will be stored in - a byte array and returned. Defaults to UTF-8. - :return-map - when followed by boolean true, sh returns a map of - :exit => sub-process's exit code - :out => sub-process's stdout (as byte[] or String) - :err => sub-process's stderr (as byte[] or String) - when not given or followed by false, sh returns a single - array or String of the sub-process's stdout followed by its - stderr - :env override the process env with a map (or the underlying Java - String[] if you are a masochist). - :dir override the process dir with a String or java.io.File. - - You can bind :env or :dir for multiple operations using with-sh-env - and with-sh-dir." - [& args] - (let [opts (parse-args args) - proc (.exec (Runtime/getRuntime) - (into-array (:cmd opts)) - (as-env-string (:env opts)) - (as-file (:dir opts)))] - (if (:in opts) - (with-open [osw (OutputStreamWriter. (.getOutputStream proc))] - (.write osw (:in opts))) - (.close (.getOutputStream proc))) - (with-open [stdout (.getInputStream proc) - stderr (.getErrorStream proc)] - (let [[[out err] combine-fn] - (if (= (:out opts) :bytes) - [(for [strm [stdout stderr]] - (into-array Byte/TYPE (map byte (stream-seq strm)))) - #(aconcat Byte/TYPE %1 %2)] - [(for [strm [stdout stderr]] - (apply str (map char (stream-seq - (InputStreamReader. strm (:out opts)))))) - str]) - exit-code (.waitFor proc)] - (if (:return-map opts) - {:exit exit-code :out out :err err} - (combine-fn out err)))))) - -(comment - -(println (sh "ls" "-l")) -(println (sh "ls" "-l" "/no-such-thing")) -(println (sh "sed" "s/[aeiou]/oo/g" :in "hello there\n")) -(println (sh "cat" :in "x\u25bax\n")) -(println (sh "echo" "x\u25bax")) -(println (sh "echo" "x\u25bax" :out "ISO-8859-1")) ; reads 4 single-byte chars -(println (sh "cat" "myimage.png" :out :bytes)) ; reads binary file into bytes[] - -) diff --git a/src/clojure/contrib/singleton.clj b/src/clojure/contrib/singleton.clj deleted file mode 100644 index b10223ff..00000000 --- a/src/clojure/contrib/singleton.clj +++ /dev/null @@ -1,54 +0,0 @@ -;;; singleton.clj: singleton functions - -;; by Stuart Sierra, http://stuartsierra.com/ -;; April 14, 2009 - -;; Copyright (c) Stuart Sierra, 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. - - -;; Change Log: -;; -;; April 14, 2009: added per-thread-singleton, renamed singleton to -;; global-singleton -;; -;; April 9, 2009: initial version - - -(ns - #^{:author "Stuart Sierra", - :doc "Singleton functions"} - clojure.contrib.singleton) - -(defn global-singleton - "Returns a global singleton function. f is a function of no - arguments that creates and returns some object. The singleton - function will call f just once, the first time it is needed, and - cache the value for all subsequent calls. - - Warning: global singletons are often unsafe in multi-threaded code. - Consider per-thread-singleton instead." - [f] - (let [instance (atom nil) - make-instance (fn [_] (f))] - (fn [] (or @instance (swap! instance make-instance))))) - -(defn per-thread-singleton - "Returns a per-thread singleton function. f is a function of no - arguments that creates and returns some object. The singleton - function will call f only once for each thread, and cache its value - for subsequent calls from the same thread. This allows you to - safely and lazily initialize shared objects on a per-thread basis. - - Warning: due to a bug in JDK 5, it may not be safe to use a - per-thread-singleton in the initialization function for another - per-thread-singleton. See - http://bugs.sun.com/bugdatabase/view_bug.do?bug_id=5025230" - [f] - (let [thread-local (proxy [ThreadLocal] [] (initialValue [] (f)))] - (fn [] (.get thread-local)))) diff --git a/src/clojure/contrib/sql.clj b/src/clojure/contrib/sql.clj deleted file mode 100644 index 5398c499..00000000 --- a/src/clojure/contrib/sql.clj +++ /dev/null @@ -1,203 +0,0 @@ -;; Copyright (c) Stephen C. Gilardi. 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. -;; -;; sql.clj -;; -;; A Clojure interface to sql databases via jdbc -;; -;; See clojure.contrib.sql.test for an example -;; -;; scgilardi (gmail) -;; Created 2 April 2008 - -(ns - #^{:author "Stephen C. Gilardi", - :doc "A Clojure interface to sql databases via jdbc - - See clojure.contrib.sql.test for an example" - :see-also [["http://code.google.com/p/clojure-contrib/source/browse/trunk/src/clojure/contrib/sql/test.clj" - "Example code"]]} - clojure.contrib.sql - (:use (clojure.contrib - [def :only (defalias)] - [java-utils :only (as-str)]) - clojure.contrib.sql.internal)) - -(defalias find-connection find-connection*) -(defalias connection connection*) - -(defmacro with-connection - "Evaluates body in the context of a new connection to a database then - closes the connection. db-spec is a map containing values for one of the - following parameter sets: - - Factory: - :factory (required) a function of one argument, a map of params - (others) (optional) passed to the factory function in a map - - DriverManager: - :classname (required) a String, the jdbc driver class name - :subprotocol (required) a String, the jdbc subprotocol - :subname (required) a String, the jdbc subname - (others) (optional) passed to the driver as properties. - - DataSource: - :datasource (required) a javax.sql.DataSource - :username (optional) a String - :password (optional) a String, required if :username is supplied - - JNDI: - :name (required) a String or javax.naming.Name - :environment (optional) a java.util.Map" - [db-spec & body] - `(with-connection* ~db-spec (fn [] ~@body))) - -(defmacro transaction - "Evaluates body as a transaction on the open database connection. Any - nested transactions are absorbed into the outermost transaction. By - default, all database updates are committed together as a group after - evaluating the outermost body, or rolled back on any uncaught - exception. If set-rollback-only is called within scope of the outermost - transaction, the entire transaction will be rolled back rather than - committed when complete." - [& body] - `(transaction* (fn [] ~@body))) - -(defn set-rollback-only - "Marks the outermost transaction such that it will rollback rather than - commit when complete" - [] - (rollback true)) - -(defn is-rollback-only - "Returns true if the outermost transaction will rollback rather than - commit when complete" - [] - (rollback)) - -(defn do-commands - "Executes SQL commands on the open database connection." - [& commands] - (with-open [stmt (.createStatement (connection))] - (doseq [cmd commands] - (.addBatch stmt cmd)) - (transaction - (seq (.executeBatch stmt))))) - -(defn do-prepared - "Executes an (optionally parameterized) SQL prepared statement on the - open database connection. Each param-group is a seq of values for all of - the parameters." - [sql & param-groups] - (with-open [stmt (.prepareStatement (connection) sql)] - (doseq [param-group param-groups] - (doseq [[index value] (map vector (iterate inc 1) param-group)] - (.setObject stmt index value)) - (.addBatch stmt)) - (transaction - (seq (.executeBatch stmt))))) - -(defn create-table - "Creates a table on the open database connection given a table name and - specs. Each spec is either a column spec: a vector containing a column - name and optionally a type and other constraints, or a table-level - constraint: a vector containing words that express the constraint. All - words used to describe the table may be supplied as strings or keywords." - [name & specs] - (do-commands - (format "CREATE TABLE %s (%s)" - (as-str name) - (apply str - (map as-str - (apply concat - (interpose [", "] - (map (partial interpose " ") specs)))))))) - -(defn drop-table - "Drops a table on the open database connection given its name, a string - or keyword" - [name] - (do-commands - (format "DROP TABLE %s" (as-str name)))) - -(defn insert-values - "Inserts rows into a table with values for specified columns only. - column-names is a vector of strings or keywords identifying columns. Each - value-group is a vector containing a values for each column in - order. When inserting complete rows (all columns), consider using - insert-rows instead." - [table column-names & value-groups] - (let [column-strs (map as-str column-names) - n (count (first value-groups)) - template (apply str (interpose "," (replicate n "?"))) - columns (if (seq column-names) - (format "(%s)" (apply str (interpose "," column-strs))) - "")] - (apply do-prepared - (format "INSERT INTO %s %s VALUES (%s)" - (as-str table) columns template) - value-groups))) - -(defn insert-rows - "Inserts complete rows into a table. Each row is a vector of values for - each of the table's columns in order." - [table & rows] - (apply insert-values table nil rows)) - -(defn insert-records - "Inserts records into a table. records are maps from strings or - keywords (identifying columns) to values." - [table & records] - (doseq [record records] - (insert-values table (keys record) (vals record)))) - -(defn delete-rows - "Deletes rows from a table. where-params is a vector containing a string - providing the (optionally parameterized) selection criteria followed by - values for any parameters." - [table where-params] - (let [[where & params] where-params] - (do-prepared - (format "DELETE FROM %s WHERE %s" - (as-str table) where) - params))) - -(defn update-values - "Updates values on selected rows in a table. where-params is a vector - containing a string providing the (optionally parameterized) selection - criteria followed by values for any parameters. record is a map from - strings or keywords (identifying columns) to updated values." - [table where-params record] - (let [[where & params] where-params - column-strs (map as-str (keys record)) - columns (apply str (concat (interpose "=?, " column-strs) "=?"))] - (do-prepared - (format "UPDATE %s SET %s WHERE %s" - (as-str table) columns where) - (concat (vals record) params)))) - -(defn update-or-insert-values - "Updates values on selected rows in a table, or inserts a new row when no - existing row matches the selection criteria. where-params is a vector - containing a string providing the (optionally parameterized) selection - criteria followed by values for any parameters. record is a map from - strings or keywords (identifying columns) to updated values." - [table where-params record] - (transaction - (let [result (update-values table where-params record)] - (if (zero? (first result)) - (insert-values table (keys record) (vals record)) - result)))) - -(defmacro with-query-results - "Executes a query, then evaluates body with results bound to a seq of the - results. sql-params is a vector containing a string providing - the (optionally parameterized) SQL query followed by values for any - parameters." - [results sql-params & body] - `(with-query-results* ~sql-params (fn [~results] ~@body))) diff --git a/src/clojure/contrib/sql/internal.clj b/src/clojure/contrib/sql/internal.clj deleted file mode 100644 index 290ebec3..00000000 --- a/src/clojure/contrib/sql/internal.clj +++ /dev/null @@ -1,194 +0,0 @@ -;; Copyright (c) Stephen C. Gilardi. 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. -;; -;; internal definitions for clojure.contrib.sql -;; -;; scgilardi (gmail) -;; Created 3 October 2008 - -(ns clojure.contrib.sql.internal - (:use - (clojure.contrib - [except :only (throwf throw-arg)] - [java-utils :only (as-properties)] - [seq-utils :only (indexed)])) - (:import - (clojure.lang RT) - (java.sql BatchUpdateException DriverManager SQLException Statement) - (java.util Hashtable Map) - (javax.naming InitialContext Name) - (javax.sql DataSource))) - -(def *db* {:connection nil :level 0}) - -(def special-counts - {Statement/EXECUTE_FAILED "EXECUTE_FAILED" - Statement/SUCCESS_NO_INFO "SUCCESS_NO_INFO"}) - -(defn find-connection* - "Returns the current database connection (or nil if there is none)" - [] - (:connection *db*)) - -(defn connection* - "Returns the current database connection (or throws if there is none)" - [] - (or (find-connection*) - (throwf "no current database connection"))) - -(defn rollback - "Accessor for the rollback flag on the current connection" - ([] - (deref (:rollback *db*))) - ([val] - (swap! (:rollback *db*) (fn [_] val)))) - -(defn get-connection - "Creates a connection to a database. db-spec is a map containing values - for one of the following parameter sets: - - Factory: - :factory (required) a function of one argument, a map of params - (others) (optional) passed to the factory function in a map - - DriverManager: - :classname (required) a String, the jdbc driver class name - :subprotocol (required) a String, the jdbc subprotocol - :subname (required) a String, the jdbc subname - (others) (optional) passed to the driver as properties. - - DataSource: - :datasource (required) a javax.sql.DataSource - :username (optional) a String - :password (optional) a String, required if :username is supplied - - JNDI: - :name (required) a String or javax.naming.Name - :environment (optional) a java.util.Map" - [{:keys [factory - classname subprotocol subname - datasource username password - name environment] - :as db-spec}] - (cond - factory - (factory (dissoc db-spec :factory)) - (and classname subprotocol subname) - (let [url (format "jdbc:%s:%s" subprotocol subname) - etc (dissoc db-spec :classname :subprotocol :subname)] - (RT/loadClassForName classname) - (DriverManager/getConnection url (as-properties etc))) - (and datasource username password) - (.getConnection datasource username password) - datasource - (.getConnection datasource) - name - (let [env (and environment (Hashtable. environment)) - context (InitialContext. env) - datasource (.lookup context name)] - (.getConnection datasource)) - :else - (throw-arg "db-spec %s is missing a required parameter" db-spec))) - -(defn with-connection* - "Evaluates func in the context of a new connection to a database then - closes the connection." - [db-spec func] - (with-open [con (get-connection db-spec)] - (binding [*db* (assoc *db* - :connection con :level 0 :rollback (atom false))] - (func)))) - -(defn print-sql-exception - "Prints the contents of an SQLException to stream" - [stream exception] - (.println - stream - (format (str "%s:" \newline - " Message: %s" \newline - " SQLState: %s" \newline - " Error Code: %d") - (.getSimpleName (class exception)) - (.getMessage exception) - (.getSQLState exception) - (.getErrorCode exception)))) - -(defn print-sql-exception-chain - "Prints a chain of SQLExceptions to stream" - [stream exception] - (loop [e exception] - (when e - (print-sql-exception stream e) - (recur (.getNextException e))))) - -(defn print-update-counts - "Prints the update counts from a BatchUpdateException to stream" - [stream exception] - (.println stream "Update counts:") - (doseq [[index count] (indexed (.getUpdateCounts exception))] - (.println stream (format " Statement %d: %s" - index - (get special-counts count count))))) - -(defn throw-rollback - "Sets rollback and throws a wrapped exception" - [e] - (rollback true) - (throwf e "transaction rolled back: %s" (.getMessage e))) - -(defn transaction* - "Evaluates func as a transaction on the open database connection. Any - nested transactions are absorbed into the outermost transaction. By - default, all database updates are committed together as a group after - evaluating the outermost body, or rolled back on any uncaught - exception. If rollback is set within scope of the outermost transaction, - the entire transaction will be rolled back rather than committed when - complete." - [func] - (binding [*db* (update-in *db* [:level] inc)] - (if (= (:level *db*) 1) - (let [con (connection*) - auto-commit (.getAutoCommit con)] - (io! - (.setAutoCommit con false) - (try - (func) - (catch BatchUpdateException e - (print-update-counts *err* e) - (print-sql-exception-chain *err* e) - (throw-rollback e)) - (catch SQLException e - (print-sql-exception-chain *err* e) - (throw-rollback e)) - (catch Exception e - (throw-rollback e)) - (finally - (if (rollback) - (.rollback con) - (.commit con)) - (rollback false) - (.setAutoCommit con auto-commit))))) - (func)))) - -(defn with-query-results* - "Executes a query, then evaluates func passing in a seq of the results as - an argument. The first argument is a vector containing the (optionally - parameterized) sql query string followed by values for any parameters." - [[sql & params :as sql-params] func] - (when-not (vector? sql-params) - (throw-arg "\"%s\" expected %s %s, found %s %s" - "sql-params" - "vector" - "[sql param*]" - (.getName (class sql-params)) - (pr-str sql-params))) - (with-open [stmt (.prepareStatement (connection*) sql)] - (doseq [[index value] (map vector (iterate inc 1) params)] - (.setObject stmt index value)) - (with-open [rset (.executeQuery stmt)] - (func (resultset-seq rset))))) diff --git a/src/clojure/contrib/sql/test.clj b/src/clojure/contrib/sql/test.clj deleted file mode 100644 index 4773ef06..00000000 --- a/src/clojure/contrib/sql/test.clj +++ /dev/null @@ -1,207 +0,0 @@ -;; Copyright (c) Stephen C. Gilardi. 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. -;; -;; test.clj -;; -;; test/example for clojure.contrib.sql -;; -;; scgilardi (gmail) -;; Created 13 September 2008 - -(ns clojure.contrib.sql.test - (:use [clojure.contrib.sql :as sql :only ()])) - -(def db {:classname "org.apache.derby.jdbc.EmbeddedDriver" - :subprotocol "derby" - :subname "/tmp/clojure.contrib.sql.test.db" - :create true}) - -(defn create-fruit - "Create a table" - [] - (sql/create-table - :fruit - [:name "varchar(32)" "PRIMARY KEY"] - [:appearance "varchar(32)"] - [:cost :int] - [:grade :real])) - -(defn drop-fruit - "Drop a table" - [] - (try - (sql/drop-table :fruit) - (catch Exception _))) - -(defn insert-rows-fruit - "Insert complete rows" - [] - (sql/insert-rows - :fruit - ["Apple" "red" 59 87] - ["Banana" "yellow" 29 92.2] - ["Peach" "fuzzy" 139 90.0] - ["Orange" "juicy" 89 88.6])) - -(defn insert-values-fruit - "Insert rows with values for only specific columns" - [] - (sql/insert-values - :fruit - [:name :cost] - ["Mango" 722] - ["Feijoa" 441])) - -(defn insert-records-fruit - "Insert records, maps from keys specifying columns to values" - [] - (sql/insert-records - :fruit - {:name "Pomegranate" :appearance "fresh" :cost 585} - {:name "Kiwifruit" :grade 93})) - -(defn db-write - "Write initial values to the database as a transaction" - [] - (sql/with-connection db - (sql/transaction - (drop-fruit) - (create-fruit) - (insert-rows-fruit) - (insert-values-fruit) - (insert-records-fruit))) - nil) - -(defn db-read - "Read the entire fruit table" - [] - (sql/with-connection db - (sql/with-query-results res - ["SELECT * FROM fruit"] - (doseq [rec res] - (println rec))))) - -(defn db-update-appearance-cost - "Update the appearance and cost of the named fruit" - [name appearance cost] - (sql/update-values - :fruit - ["name=?" name] - {:appearance appearance :cost cost})) - -(defn db-update - "Update two fruits as a transaction" - [] - (sql/with-connection db - (sql/transaction - (db-update-appearance-cost "Banana" "bruised" 14) - (db-update-appearance-cost "Feijoa" "green" 400))) - nil) - -(defn db-update-or-insert - "Updates or inserts a fruit" - [record] - (sql/with-connection db - (sql/update-or-insert-values - :fruit - ["name=?" (:name record)] - record))) - -(defn db-read-all - "Return all the rows of the fruit table as a vector" - [] - (sql/with-connection db - (sql/with-query-results res - ["SELECT * FROM fruit"] - (into [] res)))) - -(defn db-grade-range - "Print rows describing fruit that are within a grade range" - [min max] - (sql/with-connection db - (sql/with-query-results res - [(str "SELECT name, cost, grade " - "FROM fruit " - "WHERE grade >= ? AND grade <= ?") - min max] - (doseq [rec res] - (println rec))))) - -(defn db-grade-a - "Print rows describing all grade a fruit (grade between 90 and 100)" - [] - (db-grade-range 90 100)) - -(defn db-get-tables - "Demonstrate getting table info" - [] - (sql/with-connection db - (into [] - (resultset-seq - (-> (sql/connection) - (.getMetaData) - (.getTables nil nil nil (into-array ["TABLE" "VIEW"]))))))) - -(defn db-exception - "Demonstrate rolling back a partially completed transaction on exception" - [] - (sql/with-connection db - (sql/transaction - (sql/insert-values - :fruit - [:name :appearance] - ["Grape" "yummy"] - ["Pear" "bruised"]) - ;; at this point the insert-values call is complete, but the transaction - ;; is not. the exception will cause it to roll back leaving the database - ;; untouched. - (throw (Exception. "sql/test exception"))))) - -(defn db-sql-exception - "Demonstrate an sql exception" - [] - (sql/with-connection db - (sql/transaction - (sql/insert-values - :fruit - [:name :appearance] - ["Grape" "yummy"] - ["Pear" "bruised"] - ["Apple" "strange" "whoops"])))) - -(defn db-batchupdate-exception - "Demonstrate a batch update exception" - [] - (sql/with-connection db - (sql/transaction - (sql/do-commands - "DROP TABLE fruit" - "DROP TABLE fruit")))) - -(defn db-rollback - "Demonstrate a rollback-only trasaction" - [] - (sql/with-connection db - (sql/transaction - (prn "is-rollback-only" (sql/is-rollback-only)) - (sql/set-rollback-only) - (sql/insert-values - :fruit - [:name :appearance] - ["Grape" "yummy"] - ["Pear" "bruised"]) - (prn "is-rollback-only" (sql/is-rollback-only)) - (sql/with-query-results res - ["SELECT * FROM fruit"] - (doseq [rec res] - (println rec)))) - (prn) - (sql/with-query-results res - ["SELECT * FROM fruit"] - (doseq [rec res] - (println rec))))) diff --git a/src/clojure/contrib/str_utils.clj b/src/clojure/contrib/str_utils.clj deleted file mode 100644 index 02bf7445..00000000 --- a/src/clojure/contrib/str_utils.clj +++ /dev/null @@ -1,100 +0,0 @@ -;;; str_utils.clj -- string utilities for Clojure - -;; by Stuart Sierra <mail@stuartsierra.com> -;; April 8, 2008 - -;; Copyright (c) Stuart Sierra, 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. - - -(ns - #^{:author "Stuart Sierra", - :doc "String utilities for Clojure"} - clojure.contrib.str-utils - (:import (java.util.regex Pattern))) - -(defn re-split - "Splits the string on instances of 'pattern'. Returns a sequence of - strings. Optional 'limit' argument is the maximum number of - splits. Like Perl's 'split'." - ([#^Pattern pattern string] (seq (. pattern (split string)))) - ([#^Pattern pattern string limit] (seq (. pattern (split string limit))))) - -(defn re-partition - "Splits the string into a lazy sequence of substrings, alternating - between substrings that match the patthern and the substrings - between the matches. The sequence always starts with the substring - before the first match, or an empty string if the beginning of the - string matches. - - For example: (re-partition #\"[a-z]+\" \"abc123def\") - - Returns: (\"\" \"abc\" \"123\" \"def\")" - [#^Pattern re string] - (let [m (re-matcher re string)] - ((fn step [prevend] - (lazy-seq - (if (.find m) - (cons (.subSequence string prevend (.start m)) - (cons (re-groups m) - (step (+ (.start m) (count (.group m)))))) - (when (< prevend (.length string)) - (list (.subSequence string prevend (.length string))))))) - 0))) - -(defn re-gsub - "Replaces all instances of 'pattern' in 'string' with - 'replacement'. Like Ruby's 'String#gsub'. - - If (ifn? replacment) is true, the replacement is called with the - match. - " - [#^java.util.regex.Pattern regex replacement #^String string] - (if (ifn? replacement) - (let [parts (vec (re-partition regex string))] - (apply str - (reduce (fn [parts match-idx] - (update-in parts [match-idx] replacement)) - parts (range 1 (count parts) 2)))) - (.. regex (matcher string) (replaceAll replacement)))) - -(defn re-sub - "Replaces the first instance of 'pattern' in 'string' with - 'replacement'. Like Ruby's 'String#sub'. - - If (ifn? replacement) is true, the replacement is called with - the match. - " - [#^Pattern regex replacement #^String string] - (if (ifn? replacement) - (let [m (re-matcher regex string)] - (if (.find m) - (str (.subSequence string 0 (.start m)) - (replacement (re-groups m)) - (.subSequence string (.end m) (.length string))) - string)) - (.. regex (matcher string) (replaceFirst replacement)))) - - -(defn str-join - "Returns a string of all elements in 'sequence', separated by - 'separator'. Like Perl's 'join'." - [separator sequence] - (apply str (interpose separator sequence))) - - -(defn chop - "Removes the last character of string." - [s] - (subs s 0 (dec (count s)))) - -(defn chomp - "Removes all trailing newline \\n or return \\r characters from - string. Note: String.trim() is similar and faster." - [s] - (re-sub #"[\r\n]+$" "" s)) diff --git a/src/clojure/contrib/str_utils2.clj b/src/clojure/contrib/str_utils2.clj deleted file mode 100644 index d49351ac..00000000 --- a/src/clojure/contrib/str_utils2.clj +++ /dev/null @@ -1,373 +0,0 @@ -;;; str_utils2.clj -- functional string utilities for Clojure - -;; by Stuart Sierra, http://stuartsierra.com/ -;; August 19, 2009 - -;; Copyright (c) Stuart Sierra, 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. - - -(ns #^{:author "Stuart Sierra" - :doc "This is a library of string manipulation functions. It - is intented as a replacement for clojure.contrib.str-utils. - - You cannot (use 'clojure.contrib.str-utils2) because it defines - functions with the same names as functions in clojure.core. - Instead, do (require '[clojure.contrib.str-utils2 :as s]) - or something similar. - - Goals: - 1. Be functional - 2. String argument first, to work with -> - 3. Performance linear in string length - - Some ideas are borrowed from - http://github.com/francoisdevlin/devlinsf-clojure-utils/"} - clojure.contrib.str-utils2 - (:refer-clojure :exclude (take replace drop butlast partition - contains? get repeat reverse partial)) - (:import (java.util.regex Pattern))) - - -(defmacro dochars - "bindings => [name string] - - Repeatedly executes body, with name bound to each character in - string. Does NOT handle Unicode supplementary characters (above - U+FFFF)." - [bindings & body] - (assert (vector bindings)) - (assert (= 2 (count bindings))) - ;; This seems to be the fastest way to iterate over characters. - `(let [#^String s# ~(second bindings)] - (dotimes [i# (.length s#)] - (let [~(first bindings) (.charAt s# i#)] - ~@body)))) - - -(defmacro docodepoints - "bindings => [name string] - - Repeatedly executes body, with name bound to the integer code point - of each Unicode character in the string. Handles Unicode - supplementary characters (above U+FFFF) correctly." - [bindings & body] - (assert (vector bindings)) - (assert (= 2 (count bindings))) - (let [character (first bindings) - string (second bindings)] - `(let [#^String s# ~string - len# (.length s#)] - (loop [i# 0] - (when (< i# len#) - (let [~character (.charAt s# i#)] - (if (Character/isHighSurrogate ~character) - (let [~character (.codePointAt s# i#)] - ~@body - (recur (+ 2 i#))) - (let [~character (int ~character)] - ~@body - (recur (inc i#)))))))))) - -(defn codepoints - "Returns a sequence of integer Unicode code points in s. Handles - Unicode supplementary characters (above U+FFFF) correctly." - [#^String s] - (let [len (.length s) - f (fn thisfn [#^String s i] - (when (< i len) - (let [c (.charAt s i)] - (if (Character/isHighSurrogate c) - (cons (.codePointAt s i) (thisfn s (+ 2 i))) - (cons (int c) (thisfn s (inc i)))))))] - (lazy-seq (f s 0)))) - -(defn #^String escape - "Returns a new String by applying cmap (a function or a map) to each - character in s. If cmap returns nil, the original character is - added to the output unchanged." - [#^String s cmap] - (let [buffer (StringBuilder. (.length s))] - (dochars [c s] - (if-let [r (cmap c)] - (.append buffer r) - (.append buffer c))) - (.toString buffer))) - -(defn blank? - "True if s is nil, empty, or contains only whitespace." - [#^String s] - (every? (fn [#^Character c] (Character/isWhitespace c)) s)) - -(defn #^String take - "Take first n characters from s, up to the length of s. - - Note the argument order is the opposite of clojure.core/take; this - is to keep the string as the first argument for use with ->" - [#^String s n] - (if (< (count s) n) - s - (.substring s 0 n))) - -(defn #^String drop - "Drops first n characters from s. Returns an empty string if n is - greater than the length of s. - - Note the argument order is the opposite of clojure.core/drop; this - is to keep the string as the first argument for use with ->" - [#^String s n] - (if (< (count s) n) - "" - (.substring s n))) - -(defn #^String butlast - "Returns s without the last n characters. Returns an empty string - if n is greater than the length of s. - - Note the argument order is the opposite of clojure.core/butlast; - this is to keep the string as the first argument for use with ->" - [#^String s n] - (if (< (count s) n) - "" - (.substring s 0 (- (count s) n)))) - -(defn #^String tail - "Returns the last n characters of s." - [#^String s n] - (if (< (count s) n) - s - (.substring s (- (count s) n)))) - -(defn #^String repeat - "Returns a new String containing s repeated n times." - [#^String s n] - (apply str (clojure.core/repeat n s))) - -(defn #^String reverse - "Returns s with its characters reversed." - [#^String s] - (.toString (.reverse (StringBuilder. s)))) - -(defmulti - #^{:doc "Replaces all instances of pattern in string with replacement. - - Allowed argument types for pattern and replacement are: - 1. String and String - 2. Character and Character - 3. regex Pattern and String - (Uses java.util.regex.Matcher.replaceAll) - 4. regex Pattern and function - (Calls function with re-groups of each match, uses return - value as replacement.)" - :arglists '([string pattern replacement]) - :tag String} - replace - (fn [#^String string pattern replacement] - [(class pattern) (class replacement)])) - -(defmethod replace [String String] [#^String s #^String a #^String b] - (.replace s a b)) - -(defmethod replace [Character Character] [#^String s #^Character a #^Character b] - (.replace s a b)) - -(defmethod replace [Pattern String] [#^String s re replacement] - (.replaceAll (re-matcher re s) replacement)) - -(defmethod replace [Pattern clojure.lang.IFn] [#^String s re replacement] - (let [m (re-matcher re s)] - (let [buffer (StringBuffer. (.length s))] - (loop [] - (if (.find m) - (do (.appendReplacement m buffer (replacement (re-groups m))) - (recur)) - (do (.appendTail m buffer) - (.toString buffer))))))) - -(defmulti - #^{:doc "Replaces the first instance of pattern in s with replacement. - - Allowed argument types for pattern and replacement are: - 1. String and String - 2. regex Pattern and String - (Uses java.util.regex.Matcher.replaceAll) - 3. regex Pattern and function -" - :arglists '([s pattern replacement]) - :tag String} - replace-first - (fn [s pattern replacement] - [(class pattern) (class replacement)])) - -(defmethod replace-first [String String] [#^String s pattern replacement] - (.replaceFirst (re-matcher (Pattern/quote pattern) s) replacement)) - -(defmethod replace-first [Pattern String] [#^String s re replacement] - (.replaceFirst (re-matcher re s) replacement)) - -(defmethod replace-first [Pattern clojure.lang.IFn] [#^String s #^Pattern re f] - (let [m (re-matcher re s)] - (let [buffer (StringBuffer.)] - (if (.find m) - (let [rep (f (re-groups m))] - (.appendReplacement m buffer rep) - (.appendTail m buffer) - (str buffer)))))) - -(defn partition - "Splits the string into a lazy sequence of substrings, alternating - between substrings that match the patthern and the substrings - between the matches. The sequence always starts with the substring - before the first match, or an empty string if the beginning of the - string matches. - - For example: (partition \"abc123def\" #\"[a-z]+\") - returns: (\"\" \"abc\" \"123\" \"def\")" - [#^String s #^Pattern re] - (let [m (re-matcher re s)] - ((fn step [prevend] - (lazy-seq - (if (.find m) - (cons (.subSequence s prevend (.start m)) - (cons (re-groups m) - (step (+ (.start m) (count (.group m)))))) - (when (< prevend (.length s)) - (list (.subSequence s prevend (.length s))))))) - 0))) - -(defn #^String join - "Returns a string of all elements in coll, separated by - separator. Like Perl's join." - [#^String separator coll] - (apply str (interpose separator coll))) - -(defn #^String chop - "Removes the last character of string, does nothing on a zero-length - string." - [#^String s] - (let [size (count s)] - (if (zero? size) - s - (subs s 0 (dec (count s)))))) - -(defn #^String chomp - "Removes all trailing newline \\n or return \\r characters from - string. Note: String.trim() is similar and faster." - [#^String s] - (replace s #"[\r\n]+$" "")) - -(defn title-case [#^String s] - (throw (Exception. "title-case not implemeted yet"))) - -(defn #^String swap-case - "Changes upper case characters to lower case and vice-versa. - Handles Unicode supplementary characters correctly. Uses the - locale-sensitive String.toUpperCase() and String.toLowerCase() - methods." - [#^String s] - (let [buffer (StringBuilder. (.length s)) - ;; array to make a String from one code point - #^"[I" array (make-array Integer/TYPE 1)] - (docodepoints [c s] - (aset-int array 0 c) - (if (Character/isLowerCase c) - ;; Character.toUpperCase is not locale-sensitive, but - ;; String.toUpperCase is; so we use a String. - (.append buffer (.toUpperCase (String. array 0 1))) - (.append buffer (.toLowerCase (String. array 0 1))))) - (.toString buffer))) - -(defn #^String capitalize - "Converts first character of the string to upper-case, all other - characters to lower-case." - [#^String s] - (if (< (count s) 2) - (.toUpperCase s) - (str (.toUpperCase #^String (subs s 0 1)) - (.toLowerCase #^String (subs s 1))))) - -(defn #^String ltrim - "Removes whitespace from the left side of string." - [#^String s] - (replace s #"^\s+" "")) - -(defn #^String rtrim - "Removes whitespace from the right side of string." - [#^String s] - (replace s #"\s+$" "")) - -(defn split-lines - "Splits s on \\n or \\r\\n." - [#^String s] - (seq (.split #"\r?\n" s))) - -;; borrowed from compojure.str-utils, by James Reeves, EPL 1.0 -(defn #^String map-str - "Apply f to each element of coll, concatenate all results into a - String." - [f coll] - (apply str (map f coll))) - -;; borrowed from compojure.str-utils, by James Reeves, EPL 1.0 -(defn grep - "Filters elements of coll by a regular expression. The String - representation (with str) of each element is tested with re-find." - [re coll] - (filter (fn [x] (re-find re (str x))) coll)) - -(defn partial - "Like clojure.core/partial for functions that take their primary - argument first. - - Takes a function f and its arguments, NOT INCLUDING the first - argument. Returns a new function whose first argument will be the - first argument to f. - - Example: (str-utils2/partial str-utils2/take 2) - ;;=> (fn [s] (str-utils2/take s 2))" - [f & args] - (fn [s & more] (apply f s (concat args more)))) - - -;;; WRAPPERS - -;; The following functions are simple wrappers around java.lang.String -;; functions. They are included here for completeness, and for use -;; when mapping over a collection of strings. - -(defn #^String upper-case - "Converts string to all upper-case." - [#^String s] - (.toUpperCase s)) - -(defn #^String lower-case - "Converts string to all lower-case." - [#^String s] - (.toLowerCase s)) - -(defn split - "Splits string on a regular expression. Optional argument limit is - the maximum number of splits." - ([#^String s #^Pattern re] (seq (.split re s))) - ([#^String s #^Pattern re limit] (seq (.split re s limit)))) - -(defn #^String trim - "Removes whitespace from both ends of string." - [#^String s] - (.trim s)) - -(defn #^String contains? - "True if s contains the substring." - [#^String s substring] - (.contains s substring)) - -(defn #^String get - "Gets the i'th character in string." - [#^String s i] - (.charAt s i)) - diff --git a/src/clojure/contrib/stream_utils.clj b/src/clojure/contrib/stream_utils.clj deleted file mode 100644 index 35c5c90e..00000000 --- a/src/clojure/contrib/stream_utils.clj +++ /dev/null @@ -1,276 +0,0 @@ -;; Stream utilities - -;; by Konrad Hinsen -;; last updated May 3, 2009 - -;; Copyright (c) Konrad Hinsen, 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. - -(ns - #^{:author "Konrad Hinsen" - :doc "Functions for setting up computational pipelines via data streams. - - NOTE: This library is experimental. It may change significantly - with future release. - - This library defines: - - an abstract stream type, whose interface consists of the - multimethod stream-next - - a macro for implementing streams - - implementations of stream for - 1) Clojure sequences, and vectors - 2) nil, representing an empty stream - - tools for writing stream transformers, including the - monad stream-m - - various utility functions for working with streams - - Streams are building blocks in the construction of computational - pipelines. A stream is represented by its current state plus - a function that takes a stream state and obtains the next item - in the stream as well as the new stream state. The state is - implemented as a Java class or a Clojure type (as defined by the - function clojure.core/type), and the function is provided as an - implementation of the multimethod stream-next for this class or type. - - While setting up pipelines using this mechanism is somewhat more - cumbersome than using Clojure's lazy seq mechanisms, there are a - few advantages: - - The state of a stream can be stored in any Clojure data structure, - and the stream can be re-generated from it any number of times. - Any number of states can be stored this way. - - The elements of the stream are never cached, so keeping a reference - to a stream state does not incur an uncontrollable memory penalty. - - Note that the stream mechanism is thread-safe as long as the - concrete stream implementations do not use any mutable state. - - Stream transformers take any number of input streams and produce one - output stream. They are typically written using the stream-m - monad. In the definition of a stream transformer, (pick s) returns - the next value of stream argument s, whereas pick-all returns the - next value of all stream arguments in the form of a vector."} - clojure.contrib.stream-utils - (:refer-clojure :exclude (deftype)) - (:use [clojure.contrib.types :only (deftype deftype-)]) - (:use [clojure.contrib.monads :only (defmonad with-monad)]) - (:use [clojure.contrib.def :only (defvar defvar-)]) - (:require [clojure.contrib.seq-utils]) - (:require [clojure.contrib.generic.collection])) - - -; -; Stream type and interface -; -(defvar stream-type ::stream - "The root type for the stream hierarchy. For each stream type, - add a derivation from this type.") - -(defmacro defstream - "Define object of the given type as a stream whose implementation - of stream-next is defined by args and body. This macro adds - a type-specific method for stream-next and derives type - from stream-type." - [type-tag args & body] - `(do - (derive ~type-tag stream-type) - (defmethod stream-next ~type-tag ~args ~@body))) - -(defvar- stream-skip ::skip - "The skip-this-item value.") - -(defn- stream-skip? - "Returns true if x is the stream-skip." - [x] - (identical? x stream-skip)) - -(defmulti stream-next - "Returns a vector [next-value new-state] where next-value is the next - item in the data stream defined by stream-state and new-state - is the new state of the stream. At the end of the stream, - next-value and new-state are nil." - {:arglists '([stream-state])} - type) - -(defmethod stream-next nil - [s] - [nil nil]) - -(defmethod stream-next clojure.lang.ISeq - [s] - (if (seq s) - [(first s) (rest s)] - [nil nil])) - -(defmethod stream-next clojure.lang.IPersistentVector - [v] - (stream-next (seq v))) - -(defn stream-seq - "Return a lazy seq on the stream. Also accessible via - clojure.contrib.seq-utils/seq-on and - clojure.contrib.generic.collection/seq for streams." - [s] - (lazy-seq - (let [[v ns] (stream-next s)] - (if (nil? ns) - nil - (cons v (stream-seq ns)))))) - -(defmethod clojure.contrib.seq-utils/seq-on stream-type - [s] - (stream-seq s)) - -(defmethod clojure.contrib.generic.collection/seq stream-type - [s] - (stream-seq s)) - -; -; Stream transformers -; -(defmonad stream-m - "Monad describing stream computations. The monadic values can be - of any type handled by stream-next." - [m-result (fn m-result-stream [v] - (fn [s] [v s])) - m-bind (fn m-bind-stream [mv f] - (fn [s] - (let [[v ss :as r] (mv s)] - (if (or (nil? ss) (stream-skip? v)) - r - ((f v) ss))))) - m-zero (fn [s] [stream-skip s]) - ]) - -(defn pick - "Return the next value of stream argument n inside a stream - transformer. When used inside of defst, the name of the stream - argument can be used instead of its index n." - [n] - (fn [streams] - (let [[v ns] (stream-next (streams n))] - (if (nil? ns) - [nil nil] - [v (assoc streams n ns)])))) - -(defn pick-all - "Return a vector containing the next value of each stream argument - inside a stream transformer." - [streams] - (let [next (map stream-next streams) - values (map first next) - streams (vec (map second next))] - (if (some nil? streams) - [nil nil] - [values streams]))) - -(deftype ::stream-transformer st-as-stream - (fn [st streams] [st streams]) - seq) - -(defstream ::stream-transformer - [[st streams]] - (loop [s streams] - (let [[v ns] (st s)] - (cond (nil? ns) [nil nil] - (stream-skip? v) (recur ns) - :else [v (st-as-stream st ns)])))) - -(defmacro defst - "Define the stream transformer name by body. - The non-stream arguments args and the stream arguments streams - are given separately, with args being possibly empty." - [name args streams & body] - (if (= (first streams) '&) - `(defn ~name ~(vec (concat args streams)) - (let [~'st (with-monad stream-m ~@body)] - (st-as-stream ~'st ~(second streams)))) - `(defn ~name ~(vec (concat args streams)) - (let [~'st (with-monad stream-m - (let [~streams (range ~(count streams))] - ~@body))] - (st-as-stream ~'st ~streams))))) - -; -; Stream utilities -; -(defn stream-drop - "Return a stream containing all but the first n elements of stream." - [n stream] - (if (zero? n) - stream - (let [[_ s] (stream-next stream)] - (recur (dec n) s)))) - -; Map a function on a stream -(deftype- ::stream-map stream-map-state) - -(defstream ::stream-map - [[f stream]] - (let [[v ns] (stream-next stream)] - (if (nil? ns) - [nil nil] - [(f v) (stream-map-state [f ns])]))) - -(defmulti stream-map - "Return a new stream by mapping the function f on the given stream." - {:arglists '([f stream])} - (fn [f stream] (type stream))) - -(defmethod stream-map :default - [f stream] - (stream-map-state [f stream])) - -(defmethod stream-map ::stream-map - [f [g stream]] - (stream-map-state [(comp f g) stream])) - -; Filter stream elements -(deftype- ::stream-filter stream-filter-state) - -(defstream ::stream-filter - [[p stream]] - (loop [stream stream] - (let [[v ns] (stream-next stream)] - (cond (nil? ns) [nil nil] - (p v) [v (stream-filter-state [p ns])] - :else (recur ns))))) - -(defmulti stream-filter - "Return a new stream that contrains the elements of stream - that satisfy the predicate p." - {:arglists '([p stream])} - (fn [p stream] (type stream))) - -(defmethod stream-filter :default - [p stream] - (stream-filter-state [p stream])) - -(defmethod stream-filter ::stream-filter - [p [q stream]] - (stream-filter-state [(fn [v] (and (q v) (p v))) stream])) - -; Flatten a stream of sequences -(deftype- ::stream-flatten stream-flatten-state) - -(defstream ::stream-flatten - [[buffer stream]] - (loop [buffer buffer - stream stream] - (if (nil? buffer) - (let [[v new-stream] (stream-next stream)] - (cond (nil? new-stream) [nil nil] - (empty? v) (recur nil new-stream) - :else (recur v new-stream))) - [(first buffer) (stream-flatten-state [(next buffer) stream])]))) - -(defn stream-flatten - "Converts a stream of sequences into a stream of the elements of the - sequences. Flattening is not recursive, only one level of nesting - will be removed." - [s] - (stream-flatten-state [nil s])) diff --git a/src/clojure/contrib/stream_utils/examples.clj b/src/clojure/contrib/stream_utils/examples.clj deleted file mode 100644 index 524423bb..00000000 --- a/src/clojure/contrib/stream_utils/examples.clj +++ /dev/null @@ -1,117 +0,0 @@ -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; Stream application examples -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(ns - #^{:author "Konrad Hinsen" - :skip-wiki true - :doc "Examples for data streams"} - clojure.contrib.stream-utils.examples - (:refer-clojure :exclude (deftype)) - (:use [clojure.contrib.stream-utils - :only (defst stream-next - pick pick-all - stream-type defstream - stream-drop stream-map stream-filter stream-flatten)]) - (:use [clojure.contrib.monads :only (domonad)]) - (:use [clojure.contrib.types :only (deftype)]) - (:require [clojure.contrib.generic.collection :as gc])) - -; -; Define a stream of Fibonacci numbers -; -(deftype ::fib-stream last-two-fib) - -(defstream ::fib-stream - [fs] - (let [[n1 n2] fs] - [n1 (last-two-fib [n2 (+ n1 n2)])])) - -(def fib-stream (last-two-fib [0 1])) - -(take 10 (gc/seq fib-stream)) - -; -; A simple random number generator, implemented as a stream -; -(deftype ::random-seed rng-seed vector seq) - -(defstream ::random-seed - [seed] - (let [[seed] seed - m 259200 - value (/ (float seed) (float m)) - next (rem (+ 54773 (* 7141 seed)) m)] - [value (rng-seed next)])) - -(take 10 (gc/seq (rng-seed 1))) - -; -; Various stream utilities -; -(take 10 (gc/seq (stream-drop 10 (rng-seed 1)))) -(gc/seq (stream-map inc (range 5))) -(gc/seq (stream-filter odd? (range 10))) -(gc/seq (stream-flatten (partition 3 (range 9)))) - -; -; Stream transformers -; - -; Transform a stream of numbers into a stream of sums of two -; consecutive numbers. -(defst sum-two [] [xs] - (domonad - [x1 (pick xs) - x2 (pick xs)] - (+ x1 x2))) - -(def s (sum-two '(1 2 3 4 5 6 7 8))) - -(let [[v1 s] (stream-next s)] - (let [[v2 s] (stream-next s)] - (let [[v3 s] (stream-next s)] - (let [[v4 s] (stream-next s)] - (let [[v5 s] (stream-next s)] - [v1 v2 v3 v4 v5]))))) - -(gc/seq s) - -; Map (for a single stream) written as a stream transformer -(defst my-map-1 [f] [xs] - (domonad - [x (pick xs)] - (f x))) - -(gc/seq (my-map-1 inc [1 2 3])) - -; Map for two stream arguments -(defst my-map-2 [f] [xs ys] - (domonad - [x (pick xs) - y (pick ys)] - (f x y))) - -(gc/seq (my-map-2 + '(1 2 3 4) '(10 20 30 40))) - -; Map for any number of stream arguments -(defst my-map [f] [& streams] - (domonad - [vs pick-all] - (apply f vs))) - -(gc/seq (my-map inc [1 2 3])) -(gc/seq (my-map + '(1 2 3 4) '(10 20 30 40))) - -; Filter written as a stream transformer -(defst my-filter [p] [xs] - (domonad - [x (pick xs) :when (p x)] - x)) - -(gc/seq (my-filter odd? [1 2 3])) - diff --git a/src/clojure/contrib/swing_utils.clj b/src/clojure/contrib/swing_utils.clj deleted file mode 100644 index 013d7d29..00000000 --- a/src/clojure/contrib/swing_utils.clj +++ /dev/null @@ -1,152 +0,0 @@ -;; Copyright (c) Stephen C. Gilardi. 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. -;; -;; clojure.contrib.swing-utils -;; -;; Useful functions for interfacing Clojure to Swing -;; -;; scgilardi (gmail) -;; Created 31 May 2009 - -(ns clojure.contrib.swing-utils - (:import (java.awt.event ActionListener KeyAdapter) - (javax.swing AbstractAction Action - JMenu JMenuBar JMenuItem - SwingUtilities)) - (:use [clojure.contrib.def :only (defvar)])) - -(defn add-action-listener - "Adds an ActionLister to component. When the action fires, f will be - invoked with the event as its first argument followed by args. - Returns the listener." - [component f & args] - (let [listener (proxy [ActionListener] [] - (actionPerformed [event] (apply f event args)))] - (.addActionListener component listener) - listener)) - -(defn add-key-typed-listener - "Adds a KeyListener to component that only responds to KeyTyped events. - When a key is typed, f is invoked with the KeyEvent as its first argument - followed by args. Returns the listener." - [component f & args] - (let [listener (proxy [KeyAdapter] [] - (keyTyped [event] (apply f event args)))] - (.addKeyListener component listener) - listener)) - -;; ---------------------------------------------------------------------- -;; Meikel Brandmeyer - -(defn do-swing* - "Runs thunk in the Swing event thread according to schedule: - - :later => schedule the execution and return immediately - - :now => wait until the execution completes." - [schedule thunk] - (cond - (= schedule :later) (SwingUtilities/invokeLater thunk) - (= schedule :now) (if (SwingUtilities/isEventDispatchThread) - (thunk) - (SwingUtilities/invokeAndWait thunk))) - nil) - -(defmacro do-swing - "Executes body in the Swing event thread asynchronously. Returns - immediately after scheduling the execution." - [& body] - `(do-swing* :later (fn [] ~@body))) - -(defmacro do-swing-and-wait - "Executes body in the Swing event thread synchronously. Returns - after the execution is complete." - [& body] - `(do-swing* :now (fn [] ~@body))) - -(defvar action-translation-table - (atom {:name Action/NAME - :accelerator Action/ACCELERATOR_KEY - :command-key Action/ACTION_COMMAND_KEY - :long-desc Action/LONG_DESCRIPTION - :short-desc Action/SHORT_DESCRIPTION - :mnemonic Action/MNEMONIC_KEY - :icon Action/SMALL_ICON}) - "Translation table for the make-action constructor.") - -(defn make-action - "Create an Action proxy from the given action spec. The standard keys - recognised are: :name, :accelerator, :command-key, :long-desc, - :short-desc, :mnemonic and :icon - corresponding to the similar named - Action properties. The :handler value is used in the actionPerformed - method of the proxy to pass on the event." - [spec] - (let [t-table @action-translation-table - handler (:handler spec) - spec (dissoc spec :handler) - spec (map (fn [[k v]] [(t-table k) v]) spec) - action (proxy [AbstractAction] [] - (actionPerformed [evt] (handler evt)))] - (doseq [[k v] spec] - (.putValue action k v)) - action)) - -(defvar menu-constructor-dispatch - (atom #{:action :handler :items}) - "An atom containing the dispatch set for the add-menu-item method.") - -(defmulti add-menu-item - "Adds a menu item to the parent according to the item description. - The item description is a map of the following structure. - - Either: - - one single :action specifying a javax.swing.Action to be associated - with the item. - - a specification suitable for make-action - - a set of :name, :mnemonic and :items keys, specifying a submenu with - the given sequence of item entries. - - an empty map specifying a separator." - {:arglists '([parent item])} - (fn add-menu-item-dispatch [_ item] - (some @menu-constructor-dispatch (keys item)))) - -(defmethod add-menu-item :action - add-menu-item-action - [parent {:keys [action]}] - (let [item (JMenuItem. action)] - (.add parent item))) - -(defmethod add-menu-item :handler - add-menu-item-handler - [parent spec] - (add-menu-item parent {:action (make-action spec)})) - -(defmethod add-menu-item :items - add-menu-item-submenu - [parent {:keys [items mnemonic name]}] - (let [menu (JMenu. name)] - (when mnemonic - (.setMnemonic menu mnemonic)) - (doseq [item items] - (add-menu-item menu item)) - (.add parent menu))) - -(defmethod add-menu-item nil ; nil meaning separator - add-menu-item-separator - [parent _] - (.addSeparator parent)) - -(defn make-menubar - "Create a menubar containing the given sequence of menu items. The menu - items are described by a map as is detailed in the docstring of the - add-menu-item function." - [menubar-items] - (let [menubar (JMenuBar.)] - (doseq [item menubar-items] - (add-menu-item menubar item)) - menubar)) - -;; ---------------------------------------------------------------------- diff --git a/src/clojure/contrib/test_contrib.clj b/src/clojure/contrib/test_contrib.clj deleted file mode 100644 index 69b624a7..00000000 --- a/src/clojure/contrib/test_contrib.clj +++ /dev/null @@ -1,45 +0,0 @@ -;; Copyright (c) Stuart Halloway. 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. -;; -;; clojure.contrib.test-contrib -;; -;; Tests for the facilities provided by clojure-contrib -;; -;; stuart.halloway (gmail) - -(ns clojure.contrib.test-contrib - (:use [clojure.test :only (run-tests)]) - (:gen-class)) - -(def test-names - [:complex-numbers :fnmap :macro-utils :monads :pprint.pretty - :pprint.cl-format :str-utils :shell-out :test-graph - :test-dataflow :test-java-utils :test-lazy-seqs - :test-trace :test-jmx :java-utils :mock-test :mock-test.test-adapter-test - :seq-utils-test :with-ns-test]) - -(def test-namespaces - (concat - ['clojure.contrib.math.tests 'clojure.contrib.core.tests] - (map #(symbol (str "clojure.contrib.test-contrib." (name %))) - test-names))) - -(defn run - "Runs all defined tests" - [] - (println "Loading tests...") - (apply require :reload-all test-namespaces) - (apply run-tests test-namespaces)) - -(defn -main - "Run all defined tests from the command line" - [& args] - (run) - (System/exit 0)) - - diff --git a/src/clojure/contrib/test_contrib/complex_numbers.clj b/src/clojure/contrib/test_contrib/complex_numbers.clj deleted file mode 100644 index 7498e897..00000000 --- a/src/clojure/contrib/test_contrib/complex_numbers.clj +++ /dev/null @@ -1,313 +0,0 @@ -;; Test routines for complex-numbers.clj - -;; by Konrad Hinsen -;; last updated April 2, 2009 - -;; Copyright (c) Konrad Hinsen, 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. - -(ns clojure.contrib.test-contrib.complex-numbers - (:refer-clojure :exclude [+ - * / = < > <= >=]) - (:use [clojure.test - :only (deftest is are run-tests)] - [clojure.contrib.generic.arithmetic - :only (+ - * /)] - [clojure.contrib.generic.comparison - :only (= < > <= >=)] - [clojure.contrib.generic.math-functions - :only (abs approx= conjugate exp sqr sqrt)] - [clojure.contrib.complex-numbers - :only (complex imaginary real imag)])) - -(deftest complex-addition - (is (= (+ (complex 1 2) (complex 1 2)) (complex 2 4))) - (is (= (+ (complex 1 2) (complex -3 -7)) (complex -2 -5))) - (is (= (+ (complex -3 -7) (complex 1 2)) (complex -2 -5))) - (is (= (+ (complex 1 2) 3) (complex 4 2))) - (is (= (+ 3 (complex 1 2)) (complex 4 2))) - (is (= (+ (complex 1 2) -1) (imaginary 2))) - (is (= (+ -1 (complex 1 2)) (imaginary 2))) - (is (= (+ (complex 1 2) (imaginary -2)) 1)) - (is (= (+ (imaginary -2) (complex 1 2)) 1)) - (is (= (+ (complex 1 2) (imaginary 5)) (complex 1 7))) - (is (= (+ (imaginary 5) (complex 1 2)) (complex 1 7))) - (is (= (+ (complex -3 -7) (complex 1 2)) (complex -2 -5))) - (is (= (+ (complex 1 2) (complex -3 -7)) (complex -2 -5))) - (is (= (+ (complex -3 -7) (complex -3 -7)) (complex -6 -14))) - (is (= (+ (complex -3 -7) 3) (imaginary -7))) - (is (= (+ 3 (complex -3 -7)) (imaginary -7))) - (is (= (+ (complex -3 -7) -1) (complex -4 -7))) - (is (= (+ -1 (complex -3 -7)) (complex -4 -7))) - (is (= (+ (complex -3 -7) (imaginary -2)) (complex -3 -9))) - (is (= (+ (imaginary -2) (complex -3 -7)) (complex -3 -9))) - (is (= (+ (complex -3 -7) (imaginary 5)) (complex -3 -2))) - (is (= (+ (imaginary 5) (complex -3 -7)) (complex -3 -2))) - (is (= (+ 3 (complex 1 2)) (complex 4 2))) - (is (= (+ (complex 1 2) 3) (complex 4 2))) - (is (= (+ 3 (complex -3 -7)) (imaginary -7))) - (is (= (+ (complex -3 -7) 3) (imaginary -7))) - (is (= (+ 3 (imaginary -2)) (complex 3 -2))) - (is (= (+ (imaginary -2) 3) (complex 3 -2))) - (is (= (+ 3 (imaginary 5)) (complex 3 5))) - (is (= (+ (imaginary 5) 3) (complex 3 5))) - (is (= (+ -1 (complex 1 2)) (imaginary 2))) - (is (= (+ (complex 1 2) -1) (imaginary 2))) - (is (= (+ -1 (complex -3 -7)) (complex -4 -7))) - (is (= (+ (complex -3 -7) -1) (complex -4 -7))) - (is (= (+ -1 (imaginary -2)) (complex -1 -2))) - (is (= (+ (imaginary -2) -1) (complex -1 -2))) - (is (= (+ -1 (imaginary 5)) (complex -1 5))) - (is (= (+ (imaginary 5) -1) (complex -1 5))) - (is (= (+ (imaginary -2) (complex 1 2)) 1)) - (is (= (+ (complex 1 2) (imaginary -2)) 1)) - (is (= (+ (imaginary -2) (complex -3 -7)) (complex -3 -9))) - (is (= (+ (complex -3 -7) (imaginary -2)) (complex -3 -9))) - (is (= (+ (imaginary -2) 3) (complex 3 -2))) - (is (= (+ 3 (imaginary -2)) (complex 3 -2))) - (is (= (+ (imaginary -2) -1) (complex -1 -2))) - (is (= (+ -1 (imaginary -2)) (complex -1 -2))) - (is (= (+ (imaginary -2) (imaginary -2)) (imaginary -4))) - (is (= (+ (imaginary -2) (imaginary 5)) (imaginary 3))) - (is (= (+ (imaginary 5) (imaginary -2)) (imaginary 3))) - (is (= (+ (imaginary 5) (complex 1 2)) (complex 1 7))) - (is (= (+ (complex 1 2) (imaginary 5)) (complex 1 7))) - (is (= (+ (imaginary 5) (complex -3 -7)) (complex -3 -2))) - (is (= (+ (complex -3 -7) (imaginary 5)) (complex -3 -2))) - (is (= (+ (imaginary 5) 3) (complex 3 5))) - (is (= (+ 3 (imaginary 5)) (complex 3 5))) - (is (= (+ (imaginary 5) -1) (complex -1 5))) - (is (= (+ -1 (imaginary 5)) (complex -1 5))) - (is (= (+ (imaginary 5) (imaginary -2)) (imaginary 3))) - (is (= (+ (imaginary -2) (imaginary 5)) (imaginary 3))) - (is (= (+ (imaginary 5) (imaginary 5)) (imaginary 10)))) - -(deftest complex-subtraction - (is (= (- (complex 1 2) (complex 1 2)) 0)) - (is (= (- (complex 1 2) (complex -3 -7)) (complex 4 9))) - (is (= (- (complex -3 -7) (complex 1 2)) (complex -4 -9))) - (is (= (- (complex 1 2) 3) (complex -2 2))) - (is (= (- 3 (complex 1 2)) (complex 2 -2))) - (is (= (- (complex 1 2) -1) (complex 2 2))) - (is (= (- -1 (complex 1 2)) (complex -2 -2))) - (is (= (- (complex 1 2) (imaginary -2)) (complex 1 4))) - (is (= (- (imaginary -2) (complex 1 2)) (complex -1 -4))) - (is (= (- (complex 1 2) (imaginary 5)) (complex 1 -3))) - (is (= (- (imaginary 5) (complex 1 2)) (complex -1 3))) - (is (= (- (complex -3 -7) (complex 1 2)) (complex -4 -9))) - (is (= (- (complex 1 2) (complex -3 -7)) (complex 4 9))) - (is (= (- (complex -3 -7) (complex -3 -7)) 0)) - (is (= (- (complex -3 -7) 3) (complex -6 -7))) - (is (= (- 3 (complex -3 -7)) (complex 6 7))) - (is (= (- (complex -3 -7) -1) (complex -2 -7))) - (is (= (- -1 (complex -3 -7)) (complex 2 7))) - (is (= (- (complex -3 -7) (imaginary -2)) (complex -3 -5))) - (is (= (- (imaginary -2) (complex -3 -7)) (complex 3 5))) - (is (= (- (complex -3 -7) (imaginary 5)) (complex -3 -12))) - (is (= (- (imaginary 5) (complex -3 -7)) (complex 3 12))) - (is (= (- 3 (complex 1 2)) (complex 2 -2))) - (is (= (- (complex 1 2) 3) (complex -2 2))) - (is (= (- 3 (complex -3 -7)) (complex 6 7))) - (is (= (- (complex -3 -7) 3) (complex -6 -7))) - (is (= (- 3 (imaginary -2)) (complex 3 2))) - (is (= (- (imaginary -2) 3) (complex -3 -2))) - (is (= (- 3 (imaginary 5)) (complex 3 -5))) - (is (= (- (imaginary 5) 3) (complex -3 5))) - (is (= (- -1 (complex 1 2)) (complex -2 -2))) - (is (= (- (complex 1 2) -1) (complex 2 2))) - (is (= (- -1 (complex -3 -7)) (complex 2 7))) - (is (= (- (complex -3 -7) -1) (complex -2 -7))) - (is (= (- -1 (imaginary -2)) (complex -1 2))) - (is (= (- (imaginary -2) -1) (complex 1 -2))) - (is (= (- -1 (imaginary 5)) (complex -1 -5))) - (is (= (- (imaginary 5) -1) (complex 1 5))) - (is (= (- (imaginary -2) (complex 1 2)) (complex -1 -4))) - (is (= (- (complex 1 2) (imaginary -2)) (complex 1 4))) - (is (= (- (imaginary -2) (complex -3 -7)) (complex 3 5))) - (is (= (- (complex -3 -7) (imaginary -2)) (complex -3 -5))) - (is (= (- (imaginary -2) 3) (complex -3 -2))) - (is (= (- 3 (imaginary -2)) (complex 3 2))) - (is (= (- (imaginary -2) -1) (complex 1 -2))) - (is (= (- -1 (imaginary -2)) (complex -1 2))) - (is (= (- (imaginary -2) (imaginary -2)) 0)) - (is (= (- (imaginary -2) (imaginary 5)) (imaginary -7))) - (is (= (- (imaginary 5) (imaginary -2)) (imaginary 7))) - (is (= (- (imaginary 5) (complex 1 2)) (complex -1 3))) - (is (= (- (complex 1 2) (imaginary 5)) (complex 1 -3))) - (is (= (- (imaginary 5) (complex -3 -7)) (complex 3 12))) - (is (= (- (complex -3 -7) (imaginary 5)) (complex -3 -12))) - (is (= (- (imaginary 5) 3) (complex -3 5))) - (is (= (- 3 (imaginary 5)) (complex 3 -5))) - (is (= (- (imaginary 5) -1) (complex 1 5))) - (is (= (- -1 (imaginary 5)) (complex -1 -5))) - (is (= (- (imaginary 5) (imaginary -2)) (imaginary 7))) - (is (= (- (imaginary -2) (imaginary 5)) (imaginary -7))) - (is (= (- (imaginary 5) (imaginary 5)) 0))) - -(deftest complex-multiplication - (is (= (* (complex 1 2) (complex 1 2)) (complex -3 4))) - (is (= (* (complex 1 2) (complex -3 -7)) (complex 11 -13))) - (is (= (* (complex -3 -7) (complex 1 2)) (complex 11 -13))) - (is (= (* (complex 1 2) 3) (complex 3 6))) - (is (= (* 3 (complex 1 2)) (complex 3 6))) - (is (= (* (complex 1 2) -1) (complex -1 -2))) - (is (= (* -1 (complex 1 2)) (complex -1 -2))) - (is (= (* (complex 1 2) (imaginary -2)) (complex 4 -2))) - (is (= (* (imaginary -2) (complex 1 2)) (complex 4 -2))) - (is (= (* (complex 1 2) (imaginary 5)) (complex -10 5))) - (is (= (* (imaginary 5) (complex 1 2)) (complex -10 5))) - (is (= (* (complex -3 -7) (complex 1 2)) (complex 11 -13))) - (is (= (* (complex 1 2) (complex -3 -7)) (complex 11 -13))) - (is (= (* (complex -3 -7) (complex -3 -7)) (complex -40 42))) - (is (= (* (complex -3 -7) 3) (complex -9 -21))) - (is (= (* 3 (complex -3 -7)) (complex -9 -21))) - (is (= (* (complex -3 -7) -1) (complex 3 7))) - (is (= (* -1 (complex -3 -7)) (complex 3 7))) - (is (= (* (complex -3 -7) (imaginary -2)) (complex -14 6))) - (is (= (* (imaginary -2) (complex -3 -7)) (complex -14 6))) - (is (= (* (complex -3 -7) (imaginary 5)) (complex 35 -15))) - (is (= (* (imaginary 5) (complex -3 -7)) (complex 35 -15))) - (is (= (* 3 (complex 1 2)) (complex 3 6))) - (is (= (* (complex 1 2) 3) (complex 3 6))) - (is (= (* 3 (complex -3 -7)) (complex -9 -21))) - (is (= (* (complex -3 -7) 3) (complex -9 -21))) - (is (= (* 3 (imaginary -2)) (imaginary -6))) - (is (= (* (imaginary -2) 3) (imaginary -6))) - (is (= (* 3 (imaginary 5)) (imaginary 15))) - (is (= (* (imaginary 5) 3) (imaginary 15))) - (is (= (* -1 (complex 1 2)) (complex -1 -2))) - (is (= (* (complex 1 2) -1) (complex -1 -2))) - (is (= (* -1 (complex -3 -7)) (complex 3 7))) - (is (= (* (complex -3 -7) -1) (complex 3 7))) - (is (= (* -1 (imaginary -2)) (imaginary 2))) - (is (= (* (imaginary -2) -1) (imaginary 2))) - (is (= (* -1 (imaginary 5)) (imaginary -5))) - (is (= (* (imaginary 5) -1) (imaginary -5))) - (is (= (* (imaginary -2) (complex 1 2)) (complex 4 -2))) - (is (= (* (complex 1 2) (imaginary -2)) (complex 4 -2))) - (is (= (* (imaginary -2) (complex -3 -7)) (complex -14 6))) - (is (= (* (complex -3 -7) (imaginary -2)) (complex -14 6))) - (is (= (* (imaginary -2) 3) (imaginary -6))) - (is (= (* 3 (imaginary -2)) (imaginary -6))) - (is (= (* (imaginary -2) -1) (imaginary 2))) - (is (= (* -1 (imaginary -2)) (imaginary 2))) - (is (= (* (imaginary -2) (imaginary -2)) -4)) - (is (= (* (imaginary -2) (imaginary 5)) 10)) - (is (= (* (imaginary 5) (imaginary -2)) 10)) - (is (= (* (imaginary 5) (complex 1 2)) (complex -10 5))) - (is (= (* (complex 1 2) (imaginary 5)) (complex -10 5))) - (is (= (* (imaginary 5) (complex -3 -7)) (complex 35 -15))) - (is (= (* (complex -3 -7) (imaginary 5)) (complex 35 -15))) - (is (= (* (imaginary 5) 3) (imaginary 15))) - (is (= (* 3 (imaginary 5)) (imaginary 15))) - (is (= (* (imaginary 5) -1) (imaginary -5))) - (is (= (* -1 (imaginary 5)) (imaginary -5))) - (is (= (* (imaginary 5) (imaginary -2)) 10)) - (is (= (* (imaginary -2) (imaginary 5)) 10)) - (is (= (* (imaginary 5) (imaginary 5)) -25))) - -(deftest complex-division - (is (= (/ (complex 1 2) (complex 1 2)) 1)) - (is (= (/ (complex 1 2) (complex -3 -7)) (complex -17/58 1/58))) - (is (= (/ (complex -3 -7) (complex 1 2)) (complex -17/5 -1/5))) - (is (= (/ (complex 1 2) 3) (complex 1/3 2/3))) - (is (= (/ 3 (complex 1 2)) (complex 3/5 -6/5))) - (is (= (/ (complex 1 2) -1) (complex -1 -2))) - (is (= (/ -1 (complex 1 2)) (complex -1/5 2/5))) - (is (= (/ (complex 1 2) (imaginary -2)) (complex -1 1/2))) - (is (= (/ (imaginary -2) (complex 1 2)) (complex -4/5 -2/5))) - (is (= (/ (complex 1 2) (imaginary 5)) (complex 2/5 -1/5))) - (is (= (/ (imaginary 5) (complex 1 2)) (complex 2 1))) - (is (= (/ (complex -3 -7) (complex 1 2)) (complex -17/5 -1/5))) - (is (= (/ (complex 1 2) (complex -3 -7)) (complex -17/58 1/58))) - (is (= (/ (complex -3 -7) (complex -3 -7)) 1)) - (is (= (/ (complex -3 -7) 3) (complex -1 -7/3))) - (is (= (/ 3 (complex -3 -7)) (complex -9/58 21/58))) - (is (= (/ (complex -3 -7) -1) (complex 3 7))) - (is (= (/ -1 (complex -3 -7)) (complex 3/58 -7/58))) - (is (= (/ (complex -3 -7) (imaginary -2)) (complex 7/2 -3/2))) - (is (= (/ (imaginary -2) (complex -3 -7)) (complex 7/29 3/29))) - (is (= (/ (complex -3 -7) (imaginary 5)) (complex -7/5 3/5))) - (is (= (/ (imaginary 5) (complex -3 -7)) (complex -35/58 -15/58))) - (is (= (/ 3 (complex 1 2)) (complex 3/5 -6/5))) - (is (= (/ (complex 1 2) 3) (complex 1/3 2/3))) - (is (= (/ 3 (complex -3 -7)) (complex -9/58 21/58))) - (is (= (/ (complex -3 -7) 3) (complex -1 -7/3))) - (is (= (/ 3 (imaginary -2)) (imaginary 1.5))) - (is (= (/ (imaginary -2) 3) (imaginary -2/3))) - (is (= (/ 3 (imaginary 5)) (imaginary -3/5))) - (is (= (/ (imaginary 5) 3) (imaginary 5/3))) - (is (= (/ -1 (complex 1 2)) (complex -1/5 2/5))) - (is (= (/ (complex 1 2) -1) (complex -1 -2))) - (is (= (/ -1 (complex -3 -7)) (complex 3/58 -7/58))) - (is (= (/ (complex -3 -7) -1) (complex 3 7))) - (is (= (/ -1 (imaginary -2)) (imaginary -1/2))) - (is (= (/ (imaginary -2) -1) (imaginary 2))) - (is (= (/ -1 (imaginary 5)) (imaginary 1/5))) - (is (= (/ (imaginary 5) -1) (imaginary -5))) - (is (= (/ (imaginary -2) (complex 1 2)) (complex -4/5 -2/5))) - (is (= (/ (complex 1 2) (imaginary -2)) (complex -1 1/2))) - (is (= (/ (imaginary -2) (complex -3 -7)) (complex 7/29 3/29))) - (is (= (/ (complex -3 -7) (imaginary -2)) (complex 7/2 -3/2))) - (is (= (/ (imaginary -2) 3) (imaginary -2/3))) - (is (= (/ 3 (imaginary -2)) (imaginary 3/2))) - (is (= (/ (imaginary -2) -1) (imaginary 2))) - (is (= (/ -1 (imaginary -2)) (imaginary -1/2))) - (is (= (/ (imaginary -2) (imaginary -2)) 1)) - (is (= (/ (imaginary -2) (imaginary 5)) -2/5)) - (is (= (/ (imaginary 5) (imaginary -2)) -5/2)) - (is (= (/ (imaginary 5) (complex 1 2)) (complex 2 1))) - (is (= (/ (complex 1 2) (imaginary 5)) (complex 2/5 -1/5))) - (is (= (/ (imaginary 5) (complex -3 -7)) (complex -35/58 -15/58))) - (is (= (/ (complex -3 -7) (imaginary 5)) (complex -7/5 3/5))) - (is (= (/ (imaginary 5) 3) (imaginary 5/3))) - (is (= (/ 3 (imaginary 5)) (imaginary -3/5))) - (is (= (/ (imaginary 5) -1) (imaginary -5))) - (is (= (/ -1 (imaginary 5)) (imaginary 1/5))) - (is (= (/ (imaginary 5) (imaginary -2)) -5/2)) - (is (= (/ (imaginary -2) (imaginary 5)) -2/5)) - (is (= (/ (imaginary 5) (imaginary 5)) 1))) - -(deftest complex-conjugate - (is (= (conjugate (complex 1 2)) (complex 1 -2))) - (is (= (conjugate (complex -3 -7)) (complex -3 7))) - (is (= (conjugate (imaginary -2)) (imaginary 2))) - (is (= (conjugate (imaginary 5)) (imaginary -5)))) - -(deftest complex-abs - (doseq [c [(complex 1 2) (complex -2 3) (complex 4 -2) - (complex -3 -7) (imaginary -2) (imaginary 5)]] - (is (approx= (* c (conjugate c)) - (sqr (abs c)) - 1e-14)))) - -(deftest complex-sqrt - (doseq [c [(complex 1 2) (complex -2 3) (complex 4 -2) - (complex -3 -7) (imaginary -2) (imaginary 5)]] - (let [r (sqrt c)] - (is (approx= c (sqr r) 1e-14)) - (is (>= (real r) 0))))) - -(deftest complex-exp - (is (approx= (exp (complex 1 2)) - (complex -1.1312043837568135 2.4717266720048188) - 1e-14)) - (is (approx= (exp (complex 2 3)) - (complex -7.3151100949011028 1.0427436562359045) - 1e-14)) - (is (approx= (exp (complex 4 -2)) - (complex -22.720847417619233 -49.645957334580565) - 1e-14)) - (is (approx= (exp (complex 3 -7)) - (complex 15.142531566086868 -13.195928586605717) - 1e-14)) - (is (approx= (exp (imaginary -2)) - (complex -0.41614683654714241 -0.90929742682568171) - 1e-14)) - (is (approx= (exp (imaginary 5)) - (complex 0.2836621854632263 -0.95892427466313845) - 1e-14))) diff --git a/src/clojure/contrib/test_contrib/fnmap.clj b/src/clojure/contrib/test_contrib/fnmap.clj deleted file mode 100644 index 7fe87cc3..00000000 --- a/src/clojure/contrib/test_contrib/fnmap.clj +++ /dev/null @@ -1,39 +0,0 @@ -(ns clojure.contrib.test-contrib.fnmap - (:use clojure.contrib.fnmap - clojure.test)) - -(deftest acts-like-map - (let [m1 (fnmap get assoc :key1 1 :key2 2)] - (are [k v] (= v (get m1 k)) - :key1 1 - :key2 2 - :nonexistent-key nil) - (are [k v] (= v (k m1)) - :key1 1 - :key2 2 - :nonexistent-key nil) - (let [m2 (assoc m1 :key3 3 :key4 4)] - (are [k v] (= v (get m2 k)) - :key1 1 - :key2 2 - :key3 3 - :key4 4 - :nonexistent-key nil)))) - -(defn assoc-validate [m key value] - (if (integer? value) - (assoc m key value) - (throw (Exception. "Only integers allowed in this map!")))) - -(deftest validators - (let [m (fnmap get assoc-validate)] - (is (= 2 (:key2 (assoc m :key2 2)))) - (is (thrown? Exception (assoc m :key3 3.14))))) - -(defn get-transform [m key] - (when-let [value (m key)] - (- value))) - -(deftest transforms - (let [m (fnmap get-transform assoc)] - (is (= -2 (:key2 (assoc m :key2 2)))))) diff --git a/src/clojure/contrib/test_contrib/greatest_least.clj b/src/clojure/contrib/test_contrib/greatest_least.clj deleted file mode 100644 index f273aaf2..00000000 --- a/src/clojure/contrib/test_contrib/greatest_least.clj +++ /dev/null @@ -1,65 +0,0 @@ -(ns clojure.contrib.test-contrib.greatest-least - (:use clojure.contrib.greatest-least - [clojure.test :only (is deftest run-tests)])) - -(deftest test-greatest - (is (nil? (greatest)) "greatest with no arguments is nil") - (is (= 1 (greatest 1))) - (is (= 2 (greatest 1 2))) - (is (= 2 (greatest 2 1))) - (is (= "b" (greatest "aa" "b")))) - -(deftest test-greatest-by - (is (nil? (greatest-by identity)) "greatest-by with no arguments is nil") - (is (= "" (greatest-by count ""))) - (is (= "a" (greatest-by count "a" ""))) - (is (= "a" (greatest-by count "" "a"))) - (is (= "aa" (greatest-by count "aa" "b")))) - -(deftest test-least - (is (nil? (least)) "least with no arguments is nil") - (is (= 1 (least 1))) - (is (= 1 (least 1 2))) - (is (= 1 (least 2 1))) - (is (= "aa" (least "aa" "b")))) - -(deftest test-least-by - (is (nil? (least-by identity)) "least-by with no arguments is nil") - (is (= "" (least-by count ""))) - (is (= "" (least-by count "a" ""))) - (is (= "" (least-by count "" "a"))) - (is (= "b" (least-by count "aa" "b")))) - -(deftest test-all-greatest - (is (nil? (all-greatest)) "all-greatest with no arguments is nil") - (is (= (list 1) (all-greatest 1))) - (is (= (list 1 1) (all-greatest 1 1))) - (is (= (list 2) (all-greatest 2 1 1))) - (is (= (list 2) (all-greatest 1 2 1))) - (is (= (list 2) (all-greatest 1 1 2))) - (is (= (list :c) (all-greatest :b :c :a)))) - -(deftest test-all-greatest-by - (is (nil? (all-greatest-by identity)) "all-greatest-by with no arguments is nil") - (is (= (list "a")) (all-greatest-by count "a")) - (is (= (list "a" "a")) (all-greatest-by count "a" "a")) - (is (= (list "aa")) (all-greatest-by count "aa" "b")) - (is (= (list "aa")) (all-greatest-by count "b" "aa" "c")) - (is (= (list "cc" "aa")) (all-greatest-by count "aa" "b" "cc"))) - -(deftest test-all-least - (is (nil? (all-least)) "all-least with no arguments is nil") - (is (= (list 1) (all-least 1))) - (is (= (list 1 1) (all-least 1 1))) - (is (= (list 1 1) (all-least 2 1 1))) - (is (= (list 1 1) (all-least 1 2 1))) - (is (= (list 1 1) (all-least 1 1 2))) - (is (= (list :a) (all-least :b :c :a)))) - -(deftest test-all-least-by - (is (nil? (all-least-by identity)) "all-least-by with no arguments is nil") - (is (= (list "a")) (all-least-by count "a")) - (is (= (list "a" "a")) (all-least-by count "a" "a")) - (is (= (list "b")) (all-least-by count "aa" "b")) - (is (= (list "c" "b")) (all-least-by count "b" "aa" "c")) - (is (= (list "b")) (all-least-by count "aa" "b" "cc"))) diff --git a/src/clojure/contrib/test_contrib/java_utils.clj b/src/clojure/contrib/test_contrib/java_utils.clj deleted file mode 100644 index 44901ad1..00000000 --- a/src/clojure/contrib/test_contrib/java_utils.clj +++ /dev/null @@ -1,10 +0,0 @@ -(ns clojure.contrib.test-contrib.java-utils - (:use clojure.test clojure.contrib.java-utils)) - -(deftest t-as-str - (is (= "foo" (as-str "foo"))) - (is (= "foo" (as-str 'foo))) - (is (= "foo" (as-str :foo))) - (is (= "[1 2 3]" (as-str [1 2 3]))) - (is (= "Hello, World!" (as-str "Hello, " :World \!))) - (is (= (str {:foo :bar}) (as-str {:foo :bar})))) diff --git a/src/clojure/contrib/test_contrib/macro_utils.clj b/src/clojure/contrib/test_contrib/macro_utils.clj deleted file mode 100644 index ac1ced06..00000000 --- a/src/clojure/contrib/test_contrib/macro_utils.clj +++ /dev/null @@ -1,67 +0,0 @@ -;; Test routines for macro_utils.clj - -;; by Konrad Hinsen -;; last updated May 6, 2009 - -;; Copyright (c) Konrad Hinsen, 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. - -(ns clojure.contrib.test-contrib.macro-utils - (:use [clojure.test :only (deftest is are run-tests use-fixtures)] - [clojure.contrib.macro-utils - :only (macrolet symbol-macrolet defsymbolmacro with-symbol-macros - mexpand-1 mexpand mexpand-all)] - [clojure.contrib.monads - :only (with-monad domonad)])) - -(use-fixtures :each - (fn [f] (binding [*ns* (the-ns 'clojure.contrib.test-contrib.macro-utils)] - (f)))) - -(deftest macrolet-test - (is (= (macroexpand-1 - '(macrolet [(foo [form] `(~form ~form))] (foo x))) - '(do (x x))))) - -(deftest symbol-macrolet-test - (is (= (macroexpand-1 - '(symbol-macrolet [x xx y yy] - (exp [a y] (x y)))) - '(do (exp [a yy] (xx yy))))) - (is (= (macroexpand-1 - '(symbol-macrolet [def foo] - (def def def))) - '(do (def def foo)))) - (is (= (macroexpand-1 - '(symbol-macrolet [x foo z bar] - (let [a x b y x b] [a b x z]))) - '(do (let* [a foo b y x b] [a b x bar])))) - (is (= (macroexpand-1 - '(symbol-macrolet [x foo z bar] - (fn ([x y] [x y z]) ([x y z] [x y z])))) - '(do (fn* ([x y] [x y bar]) ([x y z] [x y z]))))) - (is (= (macroexpand-1 - '(symbol-macrolet [x foo z bar] - (fn f ([x y] [x y z]) ([x y z] [x y z])))) - '(do (fn* f ([x y] [x y bar]) ([x y z] [x y z]))))) - (is (= (nth (second (macroexpand-1 - '(symbol-macrolet [x xx y yy z zz] - (domonad m [a x b y x z] [a b x z])))) 2) - '(do (m-bind xx (fn* ([a] - (m-bind yy (fn* ([b] - (m-bind zz (fn* ([x] - (m-result [a b x zz])))))))))))))) - -(deftest symbol-test - (defsymbolmacro sum-2-3 (plus 2 3)) - (is (= (macroexpand '(with-symbol-macros (+ 1 sum-2-3))) - '(do (+ 1 (plus 2 3))))) - (is (= (macroexpand '(macrolet [(plus [a b] `(+ ~a ~b))] (+ 1 sum-2-3))) - '(do (+ 1 (clojure.core/+ 2 3))))) - (ns-unmap *ns* 'sum-2-3)) - diff --git a/src/clojure/contrib/test_contrib/mock_test.clj b/src/clojure/contrib/test_contrib/mock_test.clj deleted file mode 100644 index 1737305e..00000000 --- a/src/clojure/contrib/test_contrib/mock_test.clj +++ /dev/null @@ -1,131 +0,0 @@ -(ns clojure.contrib.test-contrib.mock-test - (:use clojure.test) - (:require [clojure.contrib.mock :as mock])) - -; Used as dummy dependency functions -(defn fn1 {:dynamic true} [x] :ignore) -(defn fn2 {:dynamic true} [x y] :ignore) -(defn fn3 {:dynamic true} ([x] :ignore) - ([x y z] :ignore)) -(defn fn4 {:dynamic true} [x y & r] :ignore) - -;functions created using fn directly lack the argslist meta data -(def #^{:dynamic true} deffed-differently (fn [x] :ignore)) - -(defmacro assert-called [fn-name called? & body] - `(let [called-status?# (atom false)] - (binding [~fn-name (fn [& args#] (reset! called-status?# true))] ~@body) - (is (= ~called? @called-status?#)))) - -(deftest test-convenience - (testing "once" - (is (false? (mock/once 0))) - (is (false? (mock/once 123))) - (is (true? (mock/once 1)))) - - (testing "never" - (is (false? (mock/never 4))) - (is (true? (mock/never 0)))) - - (testing "more-than" - (is (false? ((mock/more-than 5) 3))) - (is (true? ((mock/more-than 5) 9)))) - - (testing "less-than" - (is (true? ((mock/less-than 5) 3))) - (is (false? ((mock/less-than 5) 9)))) - - (testing "between" - (is (true? ((mock/between 5 8) 6))) - (is (false? ((mock/between 5 8) 5))))) - - -(deftest test-returns - (is (= {:returns 5} (mock/returns 5))) - (is (= {:other-key "test" :returns nil} (mock/returns nil {:other-key "test"})))) - - -(deftest test-has-args - (let [ex (:has-args (mock/has-args [1]))] - (is (fn? ex)) - (is (ex 'fn1 1)) - (is (ex 'fn1 1 5 6)) - (assert-called mock/unexpected-args true (ex 'fn1 5))) - (is (contains? (mock/has-args [] {:pre-existing-key "test"}) :pre-existing-key)) - (is (true? (((mock/has-args [5]) :has-args)'fn1 5)))) - - -(deftest test-has-matching-signature - (assert-called mock/no-matching-function-signature true - (mock/has-matching-signature? 'clojure.contrib.test-contrib.mock-test/fn2 [1])) - (assert-called mock/no-matching-function-signature true - (mock/has-matching-signature? 'clojure.contrib.test-contrib.mock-test/fn3 [1 3])) - (assert-called mock/no-matching-function-signature false - (mock/has-matching-signature? 'clojure.contrib.test-contrib.mock-test/fn3 [1 3 5])) - (assert-called mock/no-matching-function-signature false - (mock/has-matching-signature? 'clojure.contrib.test-contrib.mock-test/fn4 [1 3 5 7 9])) - (assert-called mock/no-matching-function-signature false - (mock/has-matching-signature? 'clojure.contrib.test-contrib.mock-test/fn4 [1 3])) - (assert-called mock/no-matching-function-signature true - (mock/has-matching-signature? 'clojure.contrib.test-contrib.mock-test/fn4 [1])) - (assert-called mock/no-matching-function-signature false - (mock/has-matching-signature? 'clojure.contrib.test-contrib.mock-test/deffed-differently [1]))) - - -(deftest test-times - (is (fn? ((mock/times #(= 1 %)) :times))) - (is (contains? (mock/times #(= 1 %) {:existing-key "test"}) :existing-key))) - -(deftest test-make-mock - (testing "invalid arguments" - (is (thrown? IllegalArgumentException (mock/make-mock [5])))) - - (testing "valid counter and unevaluated returns" - (let [[mock counter count-checker] (mock/make-mock 'fn1 (mock/returns 5 (mock/times 1)))] - (is (fn? mock)) - (is (= 0 @counter)) - (is (= 5 (mock :ignore-me))) - (is (= 1 @counter)))) - - (testing "returns as expected" - (let [[mock] (mock/make-mock 'fn1 (mock/returns 5))] - (is (= 5 (mock :ignore)))) - (let [[mock] (mock/make-mock 'fn1 (mock/returns #(* 2 %)))] - (is (= 10 ((mock :ignore) 5)) ":returns a function should not automatically - evaluate it."))) - - (testing "calls replacement-fn and returns the result" - (let [[mock] (mock/make-mock 'fn1 (mock/calls #(* 3 %)))] - (is (= 15 (mock 5)))) - (let [[mock] (mock/make-mock 'fn1 (mock/calls #(* 2 %) (mock/returns 3)))] - (is (= 10 (mock 5))))) - - (testing "argument validation" - (let [[mock] (mock/make-mock 'fn1 (mock/has-args [#(= 5 %)]))] - (assert-called mock/unexpected-args true (mock "test")) - (is (nil? (mock 5)))))) - - -(deftest test-make-count-checker - (let [checker (mock/make-count-checker 5 5)] - (assert-called mock/incorrect-invocation-count false (checker 'fn1 5)) - (assert-called mock/incorrect-invocation-count true (checker 'fn1 3)))) - - -(deftest test-validate-counts - (assert-called mock/incorrect-invocation-count false - (mock/validate-counts (list [(fn []) (atom 0) (mock/make-count-checker #(< % 6) '#(< % 6)) 'fn1]))) - (assert-called mock/incorrect-invocation-count true - (mock/validate-counts (list [(fn []) (atom 0) (mock/make-count-checker 4 4) 'fn1])))) - - -(deftest test-expect-macro - (let [under-test (fn [x] (fn1 x))] - (is (true? (mock/expect [fn1 (mock/times 1 (mock/has-args [#(= 3 %)]))] - (under-test 3)))) - (assert-called mock/unexpected-args true (mock/expect [fn1 (mock/times 1 (mock/has-args [#(= 4 %)]))] - (under-test 3)))) - (let [under-test (fn [] (fn2 (fn1 1) 3))] - (is (true? (mock/expect [fn1 (mock/times 1 (mock/has-args [#(= 1 %)] (mock/returns 2))) - fn2 (mock/times 1 (mock/has-args [#(= 2 %) #(= 3 %)] (mock/returns 5)))] - (under-test))))))
\ No newline at end of file diff --git a/src/clojure/contrib/test_contrib/mock_test/test_adapter_test.clj b/src/clojure/contrib/test_contrib/mock_test/test_adapter_test.clj deleted file mode 100644 index 5f21ce11..00000000 --- a/src/clojure/contrib/test_contrib/mock_test/test_adapter_test.clj +++ /dev/null @@ -1,18 +0,0 @@ -(ns clojure.contrib.test-contrib.mock-test.test-adapter-test - (:use clojure.contrib.mock.test-adapter - [clojure.contrib.test-contrib.mock-test :only (assert-called)] - clojure.test)) - -(deftest test-report-problem-called - (def #^{:private true :dynamic true} fn1 (fn [x] "dummy code")) - (def #^{:private true :dynamic true} fn2 (fn [x y] "dummy code2")) - (let [under-test (fn [x] (fn1 x))] - (assert-called clojure.contrib.mock.test-adapter/report-problem - true (expect [fn1 (times 5)] (under-test "hi"))))) - -(deftest test-is-report-called - (assert-called clojure.test/report true - (clojure.contrib.mock.test-adapter/report-problem - 'fn-name 5 6 "fake problem"))) - - diff --git a/src/clojure/contrib/test_contrib/monads.clj b/src/clojure/contrib/test_contrib/monads.clj deleted file mode 100644 index f523f0ec..00000000 --- a/src/clojure/contrib/test_contrib/monads.clj +++ /dev/null @@ -1,78 +0,0 @@ -;; Test routines for monads.clj - -;; by Konrad Hinsen -;; last updated March 28, 2009 - -;; Copyright (c) Konrad Hinsen, 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. - -(ns clojure.contrib.test-contrib.monads - (:use [clojure.test :only (deftest is are run-tests)] - [clojure.contrib.monads - :only (with-monad domonad m-lift m-seq m-chain - sequence-m maybe-m state-m maybe-t sequence-t)])) - -(deftest sequence-monad - (with-monad sequence-m - (are [a b] (= a b) - (domonad [x (range 3) y (range 2)] (+ x y)) - '(0 1 1 2 2 3) - (domonad [x (range 5) y (range (+ 1 x)) :when (= (+ x y) 2)] (list x y)) - '((1 1) (2 0)) - ((m-lift 2 #(list %1 %2)) (range 3) (range 2)) - '((0 0) (0 1) (1 0) (1 1) (2 0) (2 1)) - (m-seq (replicate 3 (range 2))) - '((0 0 0) (0 0 1) (0 1 0) (0 1 1) (1 0 0) (1 0 1) (1 1 0) (1 1 1)) - ((m-chain (replicate 3 range)) 5) - '(0 0 0 1 0 0 1 0 1 2) - (m-plus (range 3) (range 2)) - '(0 1 2 0 1)))) - -(deftest maybe-monad - (with-monad maybe-m - (let [m+ (m-lift 2 +) - mdiv (fn [x y] (domonad [a x b y :when (not (zero? b))] (/ a b)))] - (are [a b] (= a b) - (m+ (m-result 1) (m-result 3)) - (m-result 4) - (mdiv (m-result 1) (m-result 3)) - (m-result (/ 1 3)) - (m+ 1 (mdiv (m-result 1) (m-result 0))) - m-zero - (m-plus m-zero (m-result 1) m-zero (m-result 2)) - (m-result 1))))) - -(deftest seq-maybe-monad - (with-monad (maybe-t sequence-m) - (letfn [(pairs [xs] ((m-lift 2 #(list %1 %2)) xs xs))] - (are [a b] (= a b) - ((m-lift 1 inc) (for [n (range 10)] (when (odd? n) n))) - '(nil 2 nil 4 nil 6 nil 8 nil 10) - (pairs (for [n (range 5)] (when (odd? n) n))) - '(nil nil (1 1) nil (1 3) nil nil nil (3 1) nil (3 3) nil nil))))) - -(deftest state-maybe-monad - (with-monad (maybe-t state-m) - (is (= (for [[a b c d] (list [1 2 3 4] [nil 2 3 4] [ 1 nil 3 4] - [nil nil 3 4] [1 2 nil nil])] - (let [f (domonad - [x (m-plus (m-result a) (m-result b)) - y (m-plus (m-result c) (m-result d))] - (+ x y))] - (f :state))) - (list [4 :state] [5 :state] [4 :state] [nil :state] [nil :state]))))) - -(deftest state-seq-monad - (with-monad (sequence-t state-m) - (is (= (let [[a b c d] [1 2 10 20] - f (domonad - [x (m-plus (m-result a) (m-result b)) - y (m-plus (m-result c) (m-result d))] - (+ x y))] - (f :state))) - (list [(list 11 21 12 22) :state])))) diff --git a/src/clojure/contrib/test_contrib/pprint/cl_format.clj b/src/clojure/contrib/test_contrib/pprint/cl_format.clj deleted file mode 100644 index 6c73e63f..00000000 --- a/src/clojure/contrib/test_contrib/pprint/cl_format.clj +++ /dev/null @@ -1,670 +0,0 @@ -;;; 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 test set tests the basic cl-format functionality - -(ns clojure.contrib.test-contrib.pprint.cl-format - (:refer-clojure :exclude [format]) - (:use [clojure.test :only (deftest are run-tests)] - clojure.contrib.test-contrib.pprint.helper - clojure.contrib.pprint)) - -(def format cl-format) - -;; TODO tests for ~A, ~D, etc. -;; TODO add tests for ~F, etc.: 0.0, 9.9999 with rounding, 9.9999E99 with rounding - -(simple-tests d-tests - (cl-format nil "~D" 0) "0" - (cl-format nil "~D" 2e6) "2000000" - (cl-format nil "~D" 2000000) "2000000" - (cl-format nil "~:D" 2000000) "2,000,000" - (cl-format nil "~D" 1/2) "1/2" - (cl-format nil "~D" 'fred) "fred" -) - -(simple-tests base-tests - (cl-format nil "~{~2r~^ ~}~%" (range 10)) - "0 1 10 11 100 101 110 111 1000 1001\n" - (with-out-str - (dotimes [i 35] - (binding [*print-base* (+ i 2)] ;print the decimal number 40 - (write 40) ;in each base from 2 to 36 - (if (zero? (mod i 10)) (prn) (cl-format true " "))))) - "101000 -1111 220 130 104 55 50 44 40 37 34 -31 2c 2a 28 26 24 22 20 1j 1i -1h 1g 1f 1e 1d 1c 1b 1a 19 18 -17 16 15 14 " - (with-out-str - (doseq [pb [2 3 8 10 16]] - (binding [*print-radix* true ;print the integer 10 and - *print-base* pb] ;the ratio 1/10 in bases 2, - (cl-format true "~&~S ~S~%" 10 1/10)))) ;3, 8, 10, 16 - "#b1010 #b1/1010 -#3r101 #3r1/101 -#o12 #o1/12 -10. #10r1/10 -#xa #x1/a -") - - - -(simple-tests cardinal-tests - (cl-format nil "~R" 0) "zero" - (cl-format nil "~R" 4) "four" - (cl-format nil "~R" 15) "fifteen" - (cl-format nil "~R" -15) "minus fifteen" - (cl-format nil "~R" 25) "twenty-five" - (cl-format nil "~R" 20) "twenty" - (cl-format nil "~R" 200) "two hundred" - (cl-format nil "~R" 203) "two hundred three" - - (cl-format nil "~R" 44879032) - "forty-four million, eight hundred seventy-nine thousand, thirty-two" - - (cl-format nil "~R" -44879032) - "minus forty-four million, eight hundred seventy-nine thousand, thirty-two" - - (cl-format nil "~R = ~:*~:D" 44000032) - "forty-four million, thirty-two = 44,000,032" - - (cl-format nil "~R = ~:*~:D" 448790329480948209384389429384029384029842098420989842094) - "four hundred forty-eight septendecillion, seven hundred ninety sexdecillion, three hundred twenty-nine quindecillion, four hundred eighty quattuordecillion, nine hundred forty-eight tredecillion, two hundred nine duodecillion, three hundred eighty-four undecillion, three hundred eighty-nine decillion, four hundred twenty-nine nonillion, three hundred eighty-four octillion, twenty-nine septillion, three hundred eighty-four sextillion, twenty-nine quintillion, eight hundred forty-two quadrillion, ninety-eight trillion, four hundred twenty billion, nine hundred eighty-nine million, eight hundred forty-two thousand, ninety-four = 448,790,329,480,948,209,384,389,429,384,029,384,029,842,098,420,989,842,094" - - (cl-format nil "~R = ~:*~:D" 448790329480948209384389429384029384029842098420989842094490320942058747587584758375847593475) - "448,790,329,480,948,209,384,389,429,384,029,384,029,842,098,420,989,842,094,490,320,942,058,747,587,584,758,375,847,593,475 = 448,790,329,480,948,209,384,389,429,384,029,384,029,842,098,420,989,842,094,490,320,942,058,747,587,584,758,375,847,593,475" - - (cl-format nil "~R = ~:*~:D" 2e6) - "two million = 2,000,000" - - (cl-format nil "~R = ~:*~:D" 200000200000) - "two hundred billion, two hundred thousand = 200,000,200,000") - -(simple-tests ordinal-tests - (cl-format nil "~:R" 0) "zeroth" - (cl-format nil "~:R" 4) "fourth" - (cl-format nil "~:R" 15) "fifteenth" - (cl-format nil "~:R" -15) "minus fifteenth" - (cl-format nil "~:R" 25) "twenty-fifth" - (cl-format nil "~:R" 20) "twentieth" - (cl-format nil "~:R" 200) "two hundredth" - (cl-format nil "~:R" 203) "two hundred third" - - (cl-format nil "~:R" 44879032) - "forty-four million, eight hundred seventy-nine thousand, thirty-second" - - (cl-format nil "~:R" -44879032) - "minus forty-four million, eight hundred seventy-nine thousand, thirty-second" - - (cl-format nil "~:R = ~:*~:D" 44000032) - "forty-four million, thirty-second = 44,000,032" - - (cl-format nil "~:R = ~:*~:D" 448790329480948209384389429384029384029842098420989842094) - "four hundred forty-eight septendecillion, seven hundred ninety sexdecillion, three hundred twenty-nine quindecillion, four hundred eighty quattuordecillion, nine hundred forty-eight tredecillion, two hundred nine duodecillion, three hundred eighty-four undecillion, three hundred eighty-nine decillion, four hundred twenty-nine nonillion, three hundred eighty-four octillion, twenty-nine septillion, three hundred eighty-four sextillion, twenty-nine quintillion, eight hundred forty-two quadrillion, ninety-eight trillion, four hundred twenty billion, nine hundred eighty-nine million, eight hundred forty-two thousand, ninety-fourth = 448,790,329,480,948,209,384,389,429,384,029,384,029,842,098,420,989,842,094" - (cl-format nil "~:R = ~:*~:D" 448790329480948209384389429384029384029842098420989842094490320942058747587584758375847593475) - "448,790,329,480,948,209,384,389,429,384,029,384,029,842,098,420,989,842,094,490,320,942,058,747,587,584,758,375,847,593,475th = 448,790,329,480,948,209,384,389,429,384,029,384,029,842,098,420,989,842,094,490,320,942,058,747,587,584,758,375,847,593,475" - (cl-format nil "~:R = ~:*~:D" 448790329480948209384389429384029384029842098420989842094490320942058747587584758375847593471) - "448,790,329,480,948,209,384,389,429,384,029,384,029,842,098,420,989,842,094,490,320,942,058,747,587,584,758,375,847,593,471st = 448,790,329,480,948,209,384,389,429,384,029,384,029,842,098,420,989,842,094,490,320,942,058,747,587,584,758,375,847,593,471" - (cl-format nil "~:R = ~:*~:D" 2e6) - "two millionth = 2,000,000") - -(simple-tests ordinal1-tests - (cl-format nil "~:R" 1) "first" - (cl-format nil "~:R" 11) "eleventh" - (cl-format nil "~:R" 21) "twenty-first" - (cl-format nil "~:R" 20) "twentieth" - (cl-format nil "~:R" 220) "two hundred twentieth" - (cl-format nil "~:R" 200) "two hundredth" - (cl-format nil "~:R" 999) "nine hundred ninety-ninth" - ) - -(simple-tests roman-tests - (cl-format nil "~@R" 3) "III" - (cl-format nil "~@R" 4) "IV" - (cl-format nil "~@R" 9) "IX" - (cl-format nil "~@R" 29) "XXIX" - (cl-format nil "~@R" 429) "CDXXIX" - (cl-format nil "~@:R" 429) "CCCCXXVIIII" - (cl-format nil "~@:R" 3429) "MMMCCCCXXVIIII" - (cl-format nil "~@R" 3429) "MMMCDXXIX" - (cl-format nil "~@R" 3479) "MMMCDLXXIX" - (cl-format nil "~@R" 3409) "MMMCDIX" - (cl-format nil "~@R" 300) "CCC" - (cl-format nil "~@R ~D" 300 20) "CCC 20" - (cl-format nil "~@R" 5000) "5,000" - (cl-format nil "~@R ~D" 5000 20) "5,000 20" - (cl-format nil "~@R" "the quick") "the quick") - -(simple-tests c-tests - (cl-format nil "~{~c~^, ~}~%" "hello") "h, e, l, l, o\n" - (cl-format nil "~{~:c~^, ~}~%" "hello") "h, e, l, l, o\n" - (cl-format nil "~@C~%" \m) "\\m\n" - (cl-format nil "~@C~%" (char 222)) "\\Þ\n" - (cl-format nil "~@C~%" (char 8)) "\\backspace\n" - (cl-format nil "~@C~%" (char 3)) "\\\n") - -(simple-tests e-tests - (cl-format nil "*~E*" 0.0) "*0.0E+0*" - (cl-format nil "*~6E*" 0.0) "*0.0E+0*" - (cl-format nil "*~6,0E*" 0.0) "* 0.E+0*" - (cl-format nil "*~7,2E*" 0.0) "*0.00E+0*" - (cl-format nil "*~5E*" 0.0) "*0.E+0*" - (cl-format nil "*~10,2,2,,'?E*" 2.8E120) "*??????????*" - (cl-format nil "*~10,2E*" 9.99999) "* 1.00E+1*" - (cl-format nil "*~10,2E*" 9.99999E99) "* 1.00E+100*" - (cl-format nil "*~10,2,2E*" 9.99999E99) "* 1.00E+100*" - (cl-format nil "*~10,2,2,,'?E*" 9.99999E99) "*??????????*" - ) - -(simple-tests $-tests - (cl-format nil "~$" 22.3) "22.30" - (cl-format nil "~$" 22.375) "22.38" - (cl-format nil "~3,5$" 22.375) "00022.375" - (cl-format nil "~3,5,8$" 22.375) "00022.375" - (cl-format nil "~3,5,10$" 22.375) " 00022.375" - (cl-format nil "~3,5,14@$" 22.375) " +00022.375" - (cl-format nil "~3,5,14@$" 22.375) " +00022.375" - (cl-format nil "~3,5,14@:$" 22.375) "+ 00022.375" - (cl-format nil "~3,,14@:$" 0.375) "+ 0.375" - (cl-format nil "~1,1$" -12.0) "-12.0" - (cl-format nil "~1,1$" 12.0) "12.0" - (cl-format nil "~1,1$" 12.0) "12.0" - (cl-format nil "~1,1@$" 12.0) "+12.0" - (cl-format nil "~1,1,8,' @:$" 12.0) "+ 12.0" - (cl-format nil "~1,1,8,' @$" 12.0) " +12.0" - (cl-format nil "~1,1,8,' :$" 12.0) " 12.0" - (cl-format nil "~1,1,8,' $" 12.0) " 12.0" - (cl-format nil "~1,1,8,' @:$" -12.0) "- 12.0" - (cl-format nil "~1,1,8,' @$" -12.0) " -12.0" - (cl-format nil "~1,1,8,' :$" -12.0) "- 12.0" - (cl-format nil "~1,1,8,' $" -12.0) " -12.0" - (cl-format nil "~1,1$" 0.001) "0.0" - (cl-format nil "~2,1$" 0.001) "0.00" - (cl-format nil "~1,1,6$" 0.001) " 0.0" - (cl-format nil "~1,1,6$" 0.0015) " 0.0" - (cl-format nil "~2,1,6$" 0.005) " 0.01" - (cl-format nil "~2,1,6$" 0.01) " 0.01") - -(simple-tests f-tests - (cl-format nil "~,1f" -12.0) "-12.0") - -(simple-tests ampersand-tests - (cl-format nil "The quick brown ~a jumped over ~d lazy dogs" 'elephant 5) - "The quick brown elephant jumped over 5 lazy dogs" - (cl-format nil "The quick brown ~&~a jumped over ~d lazy dogs" 'elephant 5) - "The quick brown \nelephant jumped over 5 lazy dogs" - (cl-format nil "The quick brown ~&~a jumped\n~& over ~d lazy dogs" 'elephant 5) - "The quick brown \nelephant jumped\n over 5 lazy dogs" - (cl-format nil "~&The quick brown ~&~a jumped\n~& over ~d lazy dogs" 'elephant 5) - "The quick brown \nelephant jumped\n over 5 lazy dogs" - (cl-format nil "~3&The quick brown ~&~a jumped\n~& over ~d lazy dogs" 'elephant 5) - "\n\nThe quick brown \nelephant jumped\n over 5 lazy dogs" - (cl-format nil "~@{~&The quick brown ~a jumped over ~d lazy dogs~}" 'elephant 5 'fox 10) - "The quick brown elephant jumped over 5 lazy dogs\nThe quick brown fox jumped over 10 lazy dogs" - (cl-format nil "I ~[don't ~:;d~&o ~]have one~%" 0) "I don't have one\n" - (cl-format nil "I ~[don't ~:;d~&o ~]have one~%" 1) "I d\no have one\n") - -(simple-tests t-tests - (cl-format nil "~@{~&~A~8,4T~:*~A~}" - 'a 'aa 'aaa 'aaaa 'aaaaa 'aaaaaa 'aaaaaaa 'aaaaaaaa 'aaaaaaaaa 'aaaaaaaaaa) - "a a\naa aa\naaa aaa\naaaa aaaa\naaaaa aaaaa\naaaaaa aaaaaa\naaaaaaa aaaaaaa\naaaaaaaa aaaaaaaa\naaaaaaaaa aaaaaaaaa\naaaaaaaaaa aaaaaaaaaa" - (cl-format nil "~@{~&~A~,4T~:*~A~}" - 'a 'aa 'aaa 'aaaa 'aaaaa 'aaaaaa 'aaaaaaa 'aaaaaaaa 'aaaaaaaaa 'aaaaaaaaaa) - "a a\naa aa\naaa aaa\naaaa aaaa\naaaaa aaaaa\naaaaaa aaaaaa\naaaaaaa aaaaaaa\naaaaaaaa aaaaaaaa\naaaaaaaaa aaaaaaaaa\naaaaaaaaaa aaaaaaaaaa" - (cl-format nil "~@{~&~A~2,6@T~:*~A~}" 'a 'aa 'aaa 'aaaa 'aaaaa 'aaaaaa 'aaaaaaa 'aaaaaaaa 'aaaaaaaaa 'aaaaaaaaaa) - "a a\naa aa\naaa aaa\naaaa aaaa\naaaaa aaaaa\naaaaaa aaaaaa\naaaaaaa aaaaaaa\naaaaaaaa aaaaaaaa\naaaaaaaaa aaaaaaaaa\naaaaaaaaaa aaaaaaaaaa" -) - -(simple-tests paren-tests - (cl-format nil "~(PLEASE SPEAK QUIETLY IN HERE~)") "please speak quietly in here" - (cl-format nil "~@(PLEASE SPEAK QUIETLY IN HERE~)") "Please speak quietly in here" - (cl-format nil "~@:(but this Is imporTant~)") "BUT THIS IS IMPORTANT" - (cl-format nil "~:(the greAt gatsby~)!") "The Great Gatsby!" - ;; Test cases from CLtL 18.3 - string-upcase, et al. - (cl-format nil "~@:(~A~)" "Dr. Livingstone, I presume?") "DR. LIVINGSTONE, I PRESUME?" - (cl-format nil "~(~A~)" "Dr. Livingstone, I presume?") "dr. livingstone, i presume?" - (cl-format nil "~:(~A~)" " hello ") " Hello " - (cl-format nil "~:(~A~)" "occlUDeD cASEmenTs FOreSTAll iNADVertent DEFenestraTION") - "Occluded Casements Forestall Inadvertent Defenestration" - (cl-format nil "~:(~A~)" 'kludgy-hash-search) "Kludgy-Hash-Search" - (cl-format nil "~:(~A~)" "DON'T!") "Don'T!" ;not "Don't!" - (cl-format nil "~:(~A~)" "pipe 13a, foo16c") "Pipe 13a, Foo16c" -) - -(simple-tests square-bracket-tests - ;; Tests for format without modifiers - (cl-format nil "I ~[don't ~]have one~%" 0) "I don't have one\n" - (cl-format nil "I ~[don't ~]have one~%" 1) "I have one\n" - (cl-format nil "I ~[don't ~;do ~]have one~%" 0) "I don't have one\n" - (cl-format nil "I ~[don't ~;do ~]have one~%" 1) "I do have one\n" - (cl-format nil "I ~[don't ~;do ~]have one~%" 2) "I have one\n" - (cl-format nil "I ~[don't ~:;do ~]have one~%" 0) "I don't have one\n" - (cl-format nil "I ~[don't ~:;do ~]have one~%" 1) "I do have one\n" - (cl-format nil "I ~[don't ~:;do ~]have one~%" 2) "I do have one\n" - (cl-format nil "I ~[don't ~:;do ~]have one~%" 700) "I do have one\n" - - ;; Tests for format with a colon - (cl-format nil "I ~:[don't ~;do ~]have one~%" true) "I do have one\n" - (cl-format nil "I ~:[don't ~;do ~]have one~%" 700) "I do have one\n" - (cl-format nil "I ~:[don't ~;do ~]have one~%" '(a b)) "I do have one\n" - (cl-format nil "I ~:[don't ~;do ~]have one~%" nil) "I don't have one\n" - (cl-format nil "I ~:[don't ~;do ~]have one~%" false) "I don't have one\n" - - ;; Tests for format with an at sign - (cl-format nil "We had ~D wins~@[ (out of ~D tries)~].~%" 15 nil) "We had 15 wins.\n" - (cl-format nil "We had ~D wins~@[ (out of ~D tries)~].~%" 15 17) - "We had 15 wins (out of 17 tries).\n" - - ;; Format tests with directives - (cl-format nil "Max ~D: ~[Blue team ~D~;Red team ~D~:;No team ~A~].~%" 15, 0, 7) - "Max 15: Blue team 7.\n" - (cl-format nil "Max ~D: ~[Blue team ~D~;Red team ~D~:;No team ~A~].~%" 15, 1, 12) - "Max 15: Red team 12.\n" - (cl-format nil "Max ~D: ~[Blue team ~D~;Red team ~D~:;No team ~A~].~%" - 15, -1, "(system failure)") - "Max 15: No team (system failure).\n" - - ;; Nested format tests - (cl-format nil "Max ~D: ~[Blue team ~D~:[~; (complete success)~]~;Red team ~D~:;No team ~].~%" - 15, 0, 7, true) - "Max 15: Blue team 7 (complete success).\n" - (cl-format nil "Max ~D: ~[Blue team ~D~:[~; (complete success)~]~;Red team ~D~:;No team ~].~%" - 15, 0, 7, false) - "Max 15: Blue team 7.\n" - - ;; Test the selector as part of the argument - (cl-format nil "The answer is ~#[nothing~;~D~;~D out of ~D~:;something crazy~].") - "The answer is nothing." - (cl-format nil "The answer is ~#[nothing~;~D~;~D out of ~D~:;something crazy~]." 4) - "The answer is 4." - (cl-format nil "The answer is ~#[nothing~;~D~;~D out of ~D~:;something crazy~]." 7 22) - "The answer is 7 out of 22." - (cl-format nil "The answer is ~#[nothing~;~D~;~D out of ~D~:;something crazy~]." 1 2 3 4) - "The answer is something crazy." -) - -(simple-tests curly-brace-plain-tests - ;; Iteration from sublist - (cl-format nil "Coordinates are~{ [~D,~D]~}~%" [ 0, 1, 1, 0, 3, 5, 2, 1 ]) - "Coordinates are [0,1] [1,0] [3,5] [2,1]\n" - - (cl-format nil "Coordinates are~2{ [~D,~D]~}~%" [ 0, 1, 1, 0, 3, 5, 2, 1 ]) - "Coordinates are [0,1] [1,0]\n" - - (cl-format nil "Coordinates are~{ ~#[none~;<~D>~:;[~D,~D]~]~}~%" [ ]) - "Coordinates are\n" - - (cl-format nil "Coordinates are~{ ~#[none~;<~D>~:;[~D,~D]~]~:}~%" [ ]) - "Coordinates are none\n" - - (cl-format nil "Coordinates are~{ ~#[none~;<~D>~:;[~D,~D]~]~:}~%" [2 3 1]) - "Coordinates are [2,3] <1>\n" - - (cl-format nil "Coordinates are~{~:}~%" "" []) - "Coordinates are\n" - - (cl-format nil "Coordinates are~{~:}~%" " ~#[none~;<~D>~:;[~D,~D]~]" [2 3 1]) - "Coordinates are [2,3] <1>\n" - - (cl-format nil "Coordinates are~{~:}~%" " ~#[none~;<~D>~:;[~D,~D]~]" [ ]) - "Coordinates are none\n" -) - - -(simple-tests curly-brace-colon-tests - ;; Iteration from list of sublists - (cl-format nil "Coordinates are~:{ [~D,~D]~}~%" [ [0, 1], [1, 0], [3, 5], [2, 1] ]) - "Coordinates are [0,1] [1,0] [3,5] [2,1]\n" - - (cl-format nil "Coordinates are~:{ [~D,~D]~}~%" [ [0, 1, 0], [1, 0, 12], [3, 5], [2, 1] ]) - "Coordinates are [0,1] [1,0] [3,5] [2,1]\n" - - (cl-format nil "Coordinates are~2:{ [~D,~D]~}~%" [ [0, 1], [1, 0], [3, 5], [2, 1] ]) - "Coordinates are [0,1] [1,0]\n" - - (cl-format nil "Coordinates are~:{ ~#[none~;<~D>~:;[~D,~D]~]~}~%" [ ]) - "Coordinates are\n" - - (cl-format nil "Coordinates are~:{ ~#[none~;<~D>~:;[~D,~D]~]~:}~%" [ ]) - "Coordinates are none\n" - - (cl-format nil "Coordinates are~:{ ~#[none~;<~D>~:;[~D,~D]~]~:}~%" [[2 3] [1]]) - "Coordinates are [2,3] <1>\n" - - (cl-format nil "Coordinates are~:{~:}~%" "" []) - "Coordinates are\n" - - (cl-format nil "Coordinates are~:{~:}~%" " ~#[none~;<~D>~:;[~D,~D]~]" [[2 3] [1]]) - "Coordinates are [2,3] <1>\n" - - (cl-format nil "Coordinates are~:{~:}~%" " ~#[none~;<~D>~:;[~D,~D]~]" [ ]) - "Coordinates are none\n" -) - -(simple-tests curly-brace-at-tests - ;; Iteration from main list - (cl-format nil "Coordinates are~@{ [~D,~D]~}~%" 0, 1, 1, 0, 3, 5, 2, 1) - "Coordinates are [0,1] [1,0] [3,5] [2,1]\n" - - (cl-format nil "Coordinates are~2@{ [~D,~D]~}~%" 0, 1, 1, 0, 3, 5, 2, 1) - "Coordinates are [0,1] [1,0]\n" - - (cl-format nil "Coordinates are~@{ ~#[none~;<~D>~:;[~D,~D]~]~}~%") - "Coordinates are\n" - - (cl-format nil "Coordinates are~@{ ~#[none~;<~D>~:;[~D,~D]~]~:}~%") - "Coordinates are none\n" - - (cl-format nil "Coordinates are~@{ ~#[none~;<~D>~:;[~D,~D]~]~:}~%" 2 3 1) - "Coordinates are [2,3] <1>\n" - - (cl-format nil "Coordinates are~@{~:}~%" "") - "Coordinates are\n" - - (cl-format nil "Coordinates are~@{~:}~%" " ~#[none~;<~D>~:;[~D,~D]~]" 2 3 1) - "Coordinates are [2,3] <1>\n" - - (cl-format nil "Coordinates are~@{~:}~%" " ~#[none~;<~D>~:;[~D,~D]~]") - "Coordinates are none\n" -) - -(simple-tests curly-brace-colon-at-tests - ;; Iteration from sublists on the main arg list - (cl-format nil "Coordinates are~@:{ [~D,~D]~}~%" [0, 1], [1, 0], [3, 5], [2, 1] ) - "Coordinates are [0,1] [1,0] [3,5] [2,1]\n" - - (cl-format nil "Coordinates are~@:{ [~D,~D]~}~%" [0, 1, 0], [1, 0, 12], [3, 5], [2, 1] ) - "Coordinates are [0,1] [1,0] [3,5] [2,1]\n" - - (cl-format nil "Coordinates are~2@:{ [~D,~D]~}~%" [0, 1], [1, 0], [3, 5], [2, 1]) - "Coordinates are [0,1] [1,0]\n" - - (cl-format nil "Coordinates are~@:{ ~#[none~;<~D>~:;[~D,~D]~]~}~%") - "Coordinates are\n" - - (cl-format nil "Coordinates are~@:{ ~#[none~;<~D>~:;[~D,~D]~]~:}~%") - "Coordinates are none\n" - - (cl-format nil "Coordinates are~@:{ ~#[none~;<~D>~:;[~D,~D]~]~:}~%" [2 3] [1]) - "Coordinates are [2,3] <1>\n" - - (cl-format nil "Coordinates are~@:{~:}~%" "") - "Coordinates are\n" - - (cl-format nil "Coordinates are~@:{~:}~%" " ~#[none~;<~D>~:;[~D,~D]~]" [2 3] [1]) - "Coordinates are [2,3] <1>\n" - - (cl-format nil "Coordinates are~@:{~:}~%" " ~#[none~;<~D>~:;[~D,~D]~]") - "Coordinates are none\n" -) - -;; TODO tests for ~^ in ~[ constructs and other brackets -;; TODO test ~:^ generates an error when used improperly -;; TODO test ~:^ works in ~@:{...~} -(let [aseq '(a quick brown fox jumped over the lazy dog) - lseq (mapcat identity (for [x aseq] [x (.length (name x))]))] - (simple-tests up-tests - (cl-format nil "~{~a~^, ~}" aseq) "a, quick, brown, fox, jumped, over, the, lazy, dog" - (cl-format nil "~{~a~0^, ~}" aseq) "a" - (cl-format nil "~{~a~#,3^, ~}" aseq) "a, quick, brown, fox, jumped, over" - (cl-format nil "~{~a~v,3^, ~}" lseq) "a, quick, brown, fox" - (cl-format nil "~{~a~3,v,4^, ~}" lseq) "a, quick, brown, fox" -)) - -(simple-tests angle-bracket-tests - (cl-format nil "~<foo~;bar~;baz~>") "foobarbaz" - (cl-format nil "~20<foo~;bar~;baz~>") "foo bar baz" - (cl-format nil "~,,2<foo~;bar~;baz~>") "foo bar baz" - (cl-format nil "~20<~A~;~A~;~A~>" "foo" "bar" "baz") "foo bar baz" - (cl-format nil "~20:<~A~;~A~;~A~>" "foo" "bar" "baz") " foo bar baz" - (cl-format nil "~20@<~A~;~A~;~A~>" "foo" "bar" "baz") "foo bar baz " - (cl-format nil "~20@:<~A~;~A~;~A~>" "foo" "bar" "baz") " foo bar baz " - (cl-format nil "~10,,2<~A~;~A~;~A~>" "foo" "bar" "baz") "foo bar baz" - (cl-format nil "~10,10,2<~A~;~A~;~A~>" "foo" "bar" "baz") "foo bar baz" - (cl-format nil "~10,10<~A~;~A~;~A~>" "foo" "bar" "baz") "foo barbaz" - (cl-format nil "~20<~A~;~^~A~;~^~A~>" "foo" "bar" "baz") "foo bar baz" - (cl-format nil "~20<~A~;~^~A~;~^~A~>" "foo" "bar") "foo bar" - (cl-format nil "~20@<~A~;~^~A~;~^~A~>" "foo") "foo " - (cl-format nil "~20:<~A~;~^~A~;~^~A~>" "foo") " foo" -) - -(simple-tests angle-bracket-max-column-tests - (cl-format nil "~%;; ~{~<~%;; ~1,50:; ~A~>~}.~%" (into [] (.split "This function computes the circular thermodynamic coefficient of the thrombulator angle for use in determining the reaction distance" "\\s"))) - "\n;; This function computes the circular\n;; thermodynamic coefficient of the thrombulator\n;; angle for use in determining the reaction\n;; distance.\n" -(cl-format true "~%;; ~{~<~%;; ~:; ~A~>~}.~%" (into [] (.split "This function computes the circular thermodynamic coefficient of the thrombulator angle for use in determining the reaction distance." "\\s")))) - -(defn list-to-table [aseq column-width] - (let [stream (pretty-writer (java.io.StringWriter.))] - (binding [*out* stream] - (doseq [row aseq] - (doseq [col row] - (cl-format true "~4D~7,vT" col column-width)) - (prn))) - (.flush stream) - (.toString (.getWriter stream)))) - -(simple-tests column-writer-test - (list-to-table (map #(vector % (* % %) (* % % %)) (range 1 21)) 8) - " 1 1 1 \n 2 4 8 \n 3 9 27 \n 4 16 64 \n 5 25 125 \n 6 36 216 \n 7 49 343 \n 8 64 512 \n 9 81 729 \n 10 100 1000 \n 11 121 1331 \n 12 144 1728 \n 13 169 2197 \n 14 196 2744 \n 15 225 3375 \n 16 256 4096 \n 17 289 4913 \n 18 324 5832 \n 19 361 6859 \n 20 400 8000 \n") -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; The following tests are the various examples from the format -;; documentation in Common Lisp, the Language, 2nd edition, Chapter 22.3 -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defn expt [base pow] (reduce * (repeat pow base))) - -(let [x 5, y "elephant", n 3] - (simple-tests cltl-intro-tests - (format nil "foo") "foo" - (format nil "The answer is ~D." x) "The answer is 5." - (format nil "The answer is ~3D." x) "The answer is 5." - (format nil "The answer is ~3,'0D." x) "The answer is 005." - (format nil "The answer is ~:D." (expt 47 x)) "The answer is 229,345,007." - (format nil "Look at the ~A!" y) "Look at the elephant!" - (format nil "Type ~:C to ~A." (char 4) "delete all your files") - "Type Control-D to delete all your files." - (format nil "~D item~:P found." n) "3 items found." - (format nil "~R dog~:[s are~; is~] here." n (= n 1)) "three dogs are here." - (format nil "~R dog~:*~[s are~; is~:;s are~] here." n) "three dogs are here." - (format nil "Here ~[are~;is~:;are~] ~:*~R pupp~:@P." n) "Here are three puppies.")) - -(simple-tests cltl-B-tests - ;; CLtL didn't have the colons here, but the spec requires them - (format nil "~,,' ,4:B" 0xFACE) "1111 1010 1100 1110" - (format nil "~,,' ,4:B" 0x1CE) "1 1100 1110" - (format nil "~19,,' ,4:B" 0xFACE) "1111 1010 1100 1110" - ;; This one was a nice idea, but nothing in the spec supports it working this way - ;; (and SBCL doesn't work this way either) - ;(format nil "~19,,' ,4:B" 0x1CE) "0000 0001 1100 1110") - ) - -(simple-tests cltl-P-tests - (format nil "~D tr~:@P/~D win~:P" 7 1) "7 tries/1 win" - (format nil "~D tr~:@P/~D win~:P" 1 0) "1 try/0 wins" - (format nil "~D tr~:@P/~D win~:P" 1 3) "1 try/3 wins") - -(defn foo [x] - (format nil "~6,2F|~6,2,1,'*F|~6,2,,'?F|~6F|~,2F|~F" - x x x x x x)) - -(simple-tests cltl-F-tests - (foo 3.14159) " 3.14| 31.42| 3.14|3.1416|3.14|3.14159" - (foo -3.14159) " -3.14|-31.42| -3.14|-3.142|-3.14|-3.14159" - (foo 100.0) "100.00|******|100.00| 100.0|100.00|100.0" - (foo 1234.0) "1234.00|******|??????|1234.0|1234.00|1234.0" - (foo 0.006) " 0.01| 0.06| 0.01| 0.006|0.01|0.006") - -(defn foo-e [x] - (format nil - "~9,2,1,,'*E|~10,3,2,2,'?,,'$E|~9,3,2,-2,'%@E|~9,2E" - x x x x)) - -;; Clojure doesn't support float/double differences in representation -(simple-tests cltl-E-tests - (foo-e 0.0314159) " 3.14E-2| 31.42$-03|+.003E+01| 3.14E-2" ; Added this one - (foo-e 3.14159) " 3.14E+0| 31.42$-01|+.003E+03| 3.14E+0" - (foo-e -3.14159) " -3.14E+0|-31.42$-01|-.003E+03| -3.14E+0" - (foo-e 1100.0) " 1.10E+3| 11.00$+02|+.001E+06| 1.10E+3" -; In Clojure, this is identical to the above -; (foo-e 1100.0L0) " 1.10L+3| 11.00$+02|+.001L+06| 1.10L+3" - (foo-e 1.1E13) "*********| 11.00$+12|+.001E+16| 1.10E+13" - (foo-e 1.1E120) "*********|??????????|%%%%%%%%%|1.10E+120" -; Clojure doesn't support real numbers this large -; (foo-e 1.1L1200) "*********|??????????|%%%%%%%%%|1.10L+1200" -) - -(simple-tests cltl-E-scale-tests - (map - (fn [k] (format nil "Scale factor ~2D~:*: |~13,6,2,VE|" - (- k 5) 3.14159)) ;Prints 13 lines - (range 13)) - '("Scale factor -5: | 0.000003E+06|" - "Scale factor -4: | 0.000031E+05|" - "Scale factor -3: | 0.000314E+04|" - "Scale factor -2: | 0.003142E+03|" - "Scale factor -1: | 0.031416E+02|" - "Scale factor 0: | 0.314159E+01|" - "Scale factor 1: | 3.141590E+00|" - "Scale factor 2: | 31.41590E-01|" - "Scale factor 3: | 314.1590E-02|" - "Scale factor 4: | 3141.590E-03|" - "Scale factor 5: | 31415.90E-04|" - "Scale factor 6: | 314159.0E-05|" - "Scale factor 7: | 3141590.E-06|")) - -(defn foo-g [x] - (format nil - "~9,2,1,,'*G|~9,3,2,3,'?,,'$G|~9,3,2,0,'%G|~9,2G" - x x x x)) - -;; Clojure doesn't support float/double differences in representation -(simple-tests cltl-G-tests - (foo-g 0.0314159) " 3.14E-2|314.2$-04|0.314E-01| 3.14E-2" - (foo-g 0.314159) " 0.31 |0.314 |0.314 | 0.31 " - (foo-g 3.14159) " 3.1 | 3.14 | 3.14 | 3.1 " - (foo-g 31.4159) " 31. | 31.4 | 31.4 | 31. " - (foo-g 314.159) " 3.14E+2| 314. | 314. | 3.14E+2" - (foo-g 3141.59) " 3.14E+3|314.2$+01|0.314E+04| 3.14E+3" -; In Clojure, this is identical to the above -; (foo-g 3141.59L0) " 3.14L+3|314.2$+01|0.314L+04| 3.14L+3" - (foo-g 3.14E12) "*********|314.0$+10|0.314E+13| 3.14E+12" - (foo-g 3.14E120) "*********|?????????|%%%%%%%%%|3.14E+120" -; Clojure doesn't support real numbers this large -; (foo-g 3.14L1200) "*********|?????????|%%%%%%%%%|3.14L+1200" -) - -(defn type-clash-error [fun nargs argnum right-type wrong-type] - (format nil ;; CLtL has this format string slightly wrong - "~&Function ~S requires its ~:[~:R ~;~*~]~ - argument to be of type ~S,~%but it was called ~ - with an argument of type ~S.~%" - fun (= nargs 1) argnum right-type wrong-type)) - -(simple-tests cltl-Newline-tests - (type-clash-error 'aref nil 2 'integer 'vector) -"Function aref requires its second argument to be of type integer, -but it was called with an argument of type vector.\n" - (type-clash-error 'car 1 1 'list 'short-float) -"Function car requires its argument to be of type list, -but it was called with an argument of type short-float.\n") - -(simple-tests cltl-?-tests - (format nil "~? ~D" "<~A ~D>" '("Foo" 5) 7) "<Foo 5> 7" - (format nil "~? ~D" "<~A ~D>" '("Foo" 5 14) 7) "<Foo 5> 7" - (format nil "~@? ~D" "<~A ~D>" "Foo" 5 7) "<Foo 5> 7" - (format nil "~@? ~D" "<~A ~D>" "Foo" 5 14 7) "<Foo 5> 14") - -(defn f [n] (format nil "~@(~R~) error~:P detected." n)) - -(simple-tests cltl-paren-tests - (format nil "~@R ~(~@R~)" 14 14) "XIV xiv" - (f 0) "Zero errors detected." - (f 1) "One error detected." - (f 23) "Twenty-three errors detected.") - -(let [*print-level* nil *print-length* 5] - (simple-tests cltl-bracket-tests - (format nil "~@[ print level = ~D~]~@[ print length = ~D~]" - *print-level* *print-length*) - " print length = 5")) - -(let [foo "Items:~#[ none~; ~S~; ~S and ~S~ - ~:;~@{~#[~; and~] ~ - ~S~^,~}~]."] - (simple-tests cltl-bracket1-tests - (format nil foo) "Items: none." - (format nil foo 'foo) "Items: foo." - (format nil foo 'foo 'bar) "Items: foo and bar." - (format nil foo 'foo 'bar 'baz) "Items: foo, bar, and baz." - (format nil foo 'foo 'bar 'baz 'quux) "Items: foo, bar, baz, and quux.")) - -(simple-tests cltl-curly-bracket-tests - (format nil - "The winners are:~{ ~S~}." - '(fred harry jill)) - "The winners are: fred harry jill." - - (format nil "Pairs:~{ <~S,~S>~}." '(a 1 b 2 c 3)) - "Pairs: <a,1> <b,2> <c,3>." - - (format nil "Pairs:~:{ <~S,~S>~}." '((a 1) (b 2) (c 3))) - "Pairs: <a,1> <b,2> <c,3>." - - (format nil "Pairs:~@{ <~S,~S>~}." 'a 1 'b 2 'c 3) - "Pairs: <a,1> <b,2> <c,3>." - - (format nil "Pairs:~:@{ <~S,~S>~}." '(a 1) '(b 2) '(c 3)) - "Pairs: <a,1> <b,2> <c,3>.") - -(simple-tests cltl-angle-bracket-tests - (format nil "~10<foo~;bar~>") "foo bar" - (format nil "~10:<foo~;bar~>") " foo bar" - (format nil "~10:@<foo~;bar~>") " foo bar " - (format nil "~10<foobar~>") " foobar" - (format nil "~10:<foobar~>") " foobar" - (format nil "~10@<foobar~>") "foobar " - (format nil "~10:@<foobar~>") " foobar ") - -(let [donestr "Done.~^ ~D warning~:P.~^ ~D error~:P." - tellstr "~@{~@(~@[~R~^ ~]~A~)~}."] ;; The CLtL example is a little wrong here - - (simple-tests cltl-up-tests - (format nil donestr) "Done." - (format nil donestr 3) "Done. 3 warnings." - (format nil donestr 1 5) "Done. 1 warning. 5 errors." - (format nil tellstr 23) "Twenty-three." - (format nil tellstr nil "losers") "Losers." - (format nil tellstr 23 "losers") "Twenty-three losers." - (format nil "~15<~S~;~^~S~;~^~S~>" 'foo) - " foo" - (format nil "~15<~S~;~^~S~;~^~S~>" 'foo 'bar) - "foo bar" - (format nil "~15<~S~;~^~S~;~^~S~>" 'foo 'bar 'baz) - "foo bar baz")) - -(simple-tests cltl-up-x3j13-tests - (format nil - "~:{/~S~^ ...~}" - '((hot dog) (hamburger) (ice cream) (french fries))) - "/hot .../hamburger/ice .../french ..." - (format nil - "~:{/~S~:^ ...~}" - '((hot dog) (hamburger) (ice cream) (french fries))) - "/hot .../hamburger .../ice .../french" - - (format nil - "~:{/~S~#:^ ...~}" ;; This is wrong in CLtL - '((hot dog) (hamburger) (ice cream) (french fries))) - "/hot .../hamburger") - diff --git a/src/clojure/contrib/test_contrib/pprint/helper.clj b/src/clojure/contrib/test_contrib/pprint/helper.clj deleted file mode 100644 index bf25ca61..00000000 --- a/src/clojure/contrib/test_contrib/pprint/helper.clj +++ /dev/null @@ -1,21 +0,0 @@ -;;; helper.clj -- part of the pretty printer for Clojure - -;; by Tom Faulhaber -;; April 3, 2009 - -; Copyright (c) Tom Faulhaber, April 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 is just a macro to make my tests a little cleaner - -(ns clojure.contrib.test-contrib.pprint.helper - (:use [clojure.test :only (deftest are run-tests)])) - -(defmacro simple-tests [name & test-pairs] - `(deftest ~name (are [x y] (= x y) ~@test-pairs))) - diff --git a/src/clojure/contrib/test_contrib/pprint/pretty.clj b/src/clojure/contrib/test_contrib/pprint/pretty.clj deleted file mode 100644 index 01e7c87e..00000000 --- a/src/clojure/contrib/test_contrib/pprint/pretty.clj +++ /dev/null @@ -1,127 +0,0 @@ -;;; pretty.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. - -(ns clojure.contrib.test-contrib.pprint.pretty - (:use [clojure.test :only (deftest are run-tests)] - clojure.contrib.test-contrib.pprint.helper - clojure.contrib.pprint)) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; -;;; Unit tests for the pretty printer -;;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(simple-tests xp-fill-test - (binding [*print-pprint-dispatch* *simple-dispatch* - *print-right-margin* 38 - *print-miser-width* nil] - (cl-format nil "(let ~:<~@{~:<~w ~_~w~:>~^ ~:_~}~:>~_ ...)~%" - '((x 4) (*print-length* nil) (z 2) (list nil)))) - "(let ((x 4) (*print-length* nil)\n (z 2) (list nil))\n ...)\n" - - (binding [*print-pprint-dispatch* *simple-dispatch* - *print-right-margin* 22] - (cl-format nil "(let ~:<~@{~:<~w ~_~w~:>~^ ~:_~}~:>~_ ...)~%" - '((x 4) (*print-length* nil) (z 2) (list nil)))) - "(let ((x 4)\n (*print-length*\n nil)\n (z 2)\n (list nil))\n ...)\n") - -(simple-tests xp-miser-test - (binding [*print-pprint-dispatch* *simple-dispatch* - *print-right-margin* 10, *print-miser-width* 9] - (cl-format nil "~:<LIST ~@_~W ~@_~W ~@_~W~:>" '(first second third))) - "(LIST\n first\n second\n third)" - - (binding [*print-pprint-dispatch* *simple-dispatch* - *print-right-margin* 10, *print-miser-width* 8] - (cl-format nil "~:<LIST ~@_~W ~@_~W ~@_~W~:>" '(first second third))) - "(LIST first second third)") - -(simple-tests mandatory-fill-test - (cl-format nil - "<pre>~%~<Usage: ~:I~@{*~a*~^~:@_~}~:>~%</pre>~%" - [ "hello" "gooodbye" ]) - "<pre> -Usage: *hello* - *gooodbye* -</pre> -") - -(simple-tests prefix-suffix-test - (binding [*print-pprint-dispatch* *simple-dispatch* - *print-right-margin* 10, *print-miser-width* 10] - (cl-format nil "~<{~;LIST ~@_~W ~@_~W ~@_~W~;}~:>" '(first second third))) - "{LIST\n first\n second\n third}") - -(simple-tests pprint-test - (binding [*print-pprint-dispatch* *simple-dispatch*] - (write '(defn foo [x y] - (let [result (* x y)] - (if (> result 400) - (cl-format true "That number is too big") - (cl-format true "The result of ~d x ~d is ~d" x y result)))) - :stream nil)) - "(defn - foo - [x y] - (let - [result (* x y)] - (if - (> result 400) - (cl-format true \"That number is too big\") - (cl-format true \"The result of ~d x ~d is ~d\" x y result))))" - - (with-pprint-dispatch *code-dispatch* - (write '(defn foo [x y] - (let [result (* x y)] - (if (> result 400) - (cl-format true "That number is too big") - (cl-format true "The result of ~d x ~d is ~d" x y result)))) - :stream nil)) - "(defn foo [x y] - (let [result (* x y)] - (if (> result 400) - (cl-format true \"That number is too big\") - (cl-format true \"The result of ~d x ~d is ~d\" x y result))))" - - (binding [*print-pprint-dispatch* *simple-dispatch* - *print-right-margin* 15] - (write '(fn (cons (car x) (cdr y))) :stream nil)) - "(fn\n (cons\n (car x)\n (cdr y)))" - - (with-pprint-dispatch *code-dispatch* - (binding [*print-right-margin* 52] - (write - '(add-to-buffer this (make-buffer-blob (str (char c)) nil)) - :stream nil))) - "(add-to-buffer\n this\n (make-buffer-blob (str (char c)) nil))" - ) - - - -(simple-tests pprint-reader-macro-test - (with-pprint-dispatch *code-dispatch* - (write (read-string "(map #(first %) [[1 2 3] [4 5 6] [7]])") - :stream nil)) - "(map #(first %) [[1 2 3] [4 5 6] [7]])" - - (with-pprint-dispatch *code-dispatch* - (write (read-string "@@(ref (ref 1))") - :stream nil)) - "@@(ref (ref 1))" - - (with-pprint-dispatch *code-dispatch* - (write (read-string "'foo") - :stream nil)) - "'foo" -) diff --git a/src/clojure/contrib/test_contrib/seq_utils_test.clj b/src/clojure/contrib/test_contrib/seq_utils_test.clj deleted file mode 100644 index 0958fc65..00000000 --- a/src/clojure/contrib/test_contrib/seq_utils_test.clj +++ /dev/null @@ -1,127 +0,0 @@ -(ns clojure.contrib.test-contrib.seq-utils-test - (:use clojure.test - clojure.contrib.seq-utils)) - - -(deftest test-positions - (are [expected pred coll] (= expected (positions pred coll)) - [2] string? [:a :b "c"] - () :d [:a :b :c] - [0 2] #{:d} [:d :a :d :a])) - -;Upon further inspection, flatten behaves... wierd. -;These tests are what passes on August 7, 2009 -(deftest test-flatten-present - (are [expected nested-val] (= (flatten nested-val) expected) - ;simple literals - [] nil - [] 1 - [] 'test - [] :keyword - [] 1/2 - [] #"[\r\n]" - [] true - [] false - ;vectors - [1 2 3 4 5] [[1 2] [3 4 [5]]] - [1 2 3 4 5] [1 2 3 4 5] - [#{1 2} 3 4 5] [#{1 2} 3 4 5] - ;sets - [] #{} - [] #{#{1 2} 3 4 5} - [] #{1 2 3 4 5} - [] #{#{1 2} 3 4 5} - ;lists - [] '() - [1 2 3 4 5] `(1 2 3 4 5) - ;maps - [] {:a 1 :b 2} - [:a 1 :b 2] (seq {:a 1 :b 2}) - [] {[:a :b] 1 :c 2} - [:a :b 1 :c 2] (seq {[:a :b] 1 :c 2}) - [:a 1 2 :b 3] (seq {:a [1 2] :b 3}) - ;Strings - [] "12345" - [\1 \2 \3 \4 \5] (seq "12345") - ;fns - [] count - [count even? odd?] [count even? odd?])) - -(deftest test-separate - (are [test-seq] (= (separate even? test-seq) [[2 4] [1 3 5]]) - [1 2 3 4 5] - #{1 2 3 4 5} - '(1 2 3 4 5))) - -(deftest test-includes? - (is (includes? [1 2 3 4 5] 5)) - (is (not (includes? [1 2 3 4 5] 6)))) - -;Note - this does not make sense for maps and sets, because order is expected -(deftest test-indexed - (are [expected test-seq] (= (indexed test-seq) expected) - [[0 :a] [1 :b] [2 :c] [3 :d]] [:a :b :c :d] - [[0 :a] [1 :b] [2 :c] [3 :d]] '(:a :b :c :d) - [[0 \1] [1 \2] [2 \3] [3 \4]] "1234")) - -(deftest test-group-by - (is (= (group-by even? [1 2 3 4 5]) - {false [1 3 5], true [2 4]}))) - -;Note - this does not make sense for maps and sets, because order is expected -(deftest test-partition-by - (are [test-seq] (= (partition-by (comp even? count) test-seq) - [["a"] ["bb" "cccc" "dd"] ["eee" "f"] ["" "hh"]]) - ["a" "bb" "cccc" "dd" "eee" "f" "" "hh"] - '("a" "bb" "cccc" "dd" "eee" "f" "" "hh")) - (is (=(partition-by #{\a \e \i \o \u} "abcdefghijklm") - [[\a] [\b \c \d] [\e] [\f \g \h] [\i] [\j \k \l \m]]))) - -(deftest test-frequencies - (are [expected test-seq] (= (frequencies test-seq) expected) - {\p 2, \s 4, \i 4, \m 1} "mississippi" - {1 4 2 2 3 1} [1 1 1 1 2 2 3] - {1 4 2 2 3 1} '(1 1 1 1 2 2 3))) - -;Note - this does not make sense for maps and sets, because order is expected -;This is a key differnce between reductions and reduce. -(deftest test-reductions - (is (= (reductions + [1 2 3 4 5]) - [1 3 6 10 15])) - (is (= (reductions + 10 [1 2 3 4 5]) - [10 11 13 16 20 25]))) - -;Note - this does not make sense for maps and sets, because order is expected -(deftest test-rotations - (is (= (rotations [1 2 3 4]) - [[1 2 3 4] - [2 3 4 1] - [3 4 1 2] - [4 1 2 3]]))) - -;Note - this does not make sense for maps and sets, because order is expected -(deftest test-partition-all - (is (= (partition-all 4 [1 2 3 4 5 6 7 8 9]) - [[1 2 3 4] [5 6 7 8] [9]])) - (is (= (partition-all 4 2 [1 2 3 4 5 6 7 8 9]) - [[1 2 3 4] [3 4 5 6] [5 6 7 8] [7 8 9] [9]]))) - -;Thanks to Andy Fingerhut for the idea of testing invariants -(deftest test-shuffle-invariants - (is (= (count (shuffle [1 2 3 4])) 4)) - (let [shuffled-seq (shuffle [1 2 3 4])] - (is (every? #{1 2 3 4} shuffled-seq)))) - -(deftest test-shuffle-distributions - (let [a-statistician-needed-to-do-this? true] - (is a-statistician-needed-to-do-this?))) - -;Thanks to Andy Fingerhut for the idea of testing invariants -(deftest test-rand-elt-invariants - (let [elt (rand-elt [:a :b :c :d])] - (is (#{:a :b :c :d} elt)))) - -;Note - this does not make sense for maps and sets, because order is expected -(deftest test-find-first - (is (= (find-first even? [1 2 3 4 5]) 2)) - (is (= (find-first even? '(1 2 3 4 5)) 2))) diff --git a/src/clojure/contrib/test_contrib/shell_out.clj b/src/clojure/contrib/test_contrib/shell_out.clj deleted file mode 100644 index c5447099..00000000 --- a/src/clojure/contrib/test_contrib/shell_out.clj +++ /dev/null @@ -1,41 +0,0 @@ -(ns clojure.contrib.test-contrib.shell-out - (:use clojure.test - clojure.contrib.shell-out) - (:import (java.io File))) - -; workaroung to access private parse-args. Better way? -(def parse-args ((ns-interns 'clojure.contrib.shell-out) 'parse-args)) -(def as-file ((ns-interns 'clojure.contrib.shell-out) 'as-file)) -(def as-env-string ((ns-interns 'clojure.contrib.shell-out) 'as-env-string)) - -(deftest test-parse-args - (are [x y] (= x y) - {:cmd [nil] :out "UTF-8" :dir nil :env nil} (parse-args []) - {:cmd ["ls"] :out "UTF-8" :dir nil :env nil} (parse-args ["ls"]) - {:cmd ["ls" "-l"] :out "UTF-8" :dir nil :env nil} (parse-args ["ls" "-l"]) - {:cmd ["ls"] :out "ISO-8859-1" :dir nil :env nil} (parse-args ["ls" :out "ISO-8859-1"]) -)) - -(deftest test-with-sh-dir - (are [x y] (= x y) - nil *sh-dir* - "foo" (with-sh-dir "foo" *sh-dir*))) - -(deftest test-with-sh-env - (are [x y] (= x y) - nil *sh-env* - {:KEY "VAL"} (with-sh-env {:KEY "VAL"} *sh-env*))) - -(deftest test-as-env-string - (are [x y] (= x y) - nil (as-env-string nil) - ["FOO=BAR"] (seq (as-env-string {"FOO" "BAR"})) - ["FOO_SYMBOL=BAR"] (seq (as-env-string {'FOO_SYMBOL "BAR"})) - ["FOO_KEYWORD=BAR"] (seq (as-env-string {:FOO_KEYWORD "BAR"})))) - - -(deftest test-as-file - (are [x y] (= x y) - (File. "foo") (as-file "foo") - nil (as-file nil) - (File. "bar") (as-file (File. "bar"))))
\ No newline at end of file diff --git a/src/clojure/contrib/test_contrib/str_utils.clj b/src/clojure/contrib/test_contrib/str_utils.clj deleted file mode 100644 index 815525bb..00000000 --- a/src/clojure/contrib/test_contrib/str_utils.clj +++ /dev/null @@ -1,33 +0,0 @@ -(ns clojure.contrib.test-contrib.str-utils - (:use clojure.test - clojure.contrib.str-utils)) - - -(deftest test-re-gsub - (let [re #"\%([0-9a-fA-F]{2})" - replacement (fn [match] - (char (Integer/parseInt - (match 1) 16)))] - (is (= (re-gsub re replacement "") "")) - (is (= (re-gsub re replacement "%20") " ")) - (is (= (re-gsub re replacement "x%20") "x ")) - (is (= (re-gsub re replacement "x%20%0a") "x \n")) - (is (= (re-gsub re replacement "x%20y") "x y")) - (is (= (re-gsub re "?" "") "")) - (is (= (re-gsub re "?" "%21") "?")) - (is (= (re-gsub re "?" "x%22") "x?")) - (is (= (re-gsub re "?" "x%23y") "x?y")))) - -(deftest test-re-sub - (let [re #"\%([0-9a-fA-F]{2})" - replacement (fn [match] - (char (Integer/parseInt - (match 1) 16)))] - (is (= (re-sub re replacement "") "")) - (is (= (re-sub re replacement "%20") " ")) - (is (= (re-sub re replacement "x%20%20") "x %20")) - (is (= (re-sub re replacement "x%20y") "x y")) - (is (= (re-sub re "?" "") "")) - (is (= (re-sub re "?" "%21") "?")) - (is (= (re-sub re "?" "x%22%25") "x?%25")) - (is (= (re-gsub re "?" "x%23y") "x?y")))) diff --git a/src/clojure/contrib/test_contrib/str_utils2.clj b/src/clojure/contrib/test_contrib/str_utils2.clj deleted file mode 100644 index ee6aa68e..00000000 --- a/src/clojure/contrib/test_contrib/str_utils2.clj +++ /dev/null @@ -1,119 +0,0 @@ -(ns clojure.contrib.test-contrib.str-utils2 - (:require [clojure.contrib.str-utils2 :as s]) - (:use clojure.test)) - -(deftest t-codepoints - (is (= (list 102 111 111 65536 98 97 114) - (s/codepoints "foo\uD800\uDC00bar")) - "Handles Unicode supplementary characters")) - -(deftest t-escape - (is (= "<foo&bar>" - (s/escape "<foo&bar>" {\& "&" \< "<" \> ">"}))) - (is (= " \\\"foo\\\" " - (s/escape " \"foo\" " {\" "\\\""}))) - (is (= "faabor" (s/escape "foobar" {\a \o, \o \a})))) - -(deftest t-blank - (is (s/blank? nil)) - (is (s/blank? "")) - (is (s/blank? " ")) - (is (s/blank? " \t \n \r ")) - (is (not (s/blank? " foo ")))) - -(deftest t-take - (is (= "foo" (s/take "foobar" 3))) - (is (= "foobar" (s/take "foobar" 7))) - (is (= "" (s/take "foo" 0)))) - -(deftest t-drop - (is (= "bar" (s/drop "foobar" 3))) - (is (= "" (s/drop "foobar" 9))) - (is (= "foobar" (s/drop "foobar" 0)))) - -(deftest t-butlast - (is (= "foob" (s/butlast "foobar" 2))) - (is (= "" (s/butlast "foobar" 9))) - (is (= "foobar" (s/butlast "foobar" 0)))) - -(deftest t-tail - (is (= "ar" (s/tail "foobar" 2))) - (is (= "foobar" (s/tail "foobar" 9))) - (is (= "" (s/tail "foobar" 0)))) - -(deftest t-repeat - (is (= "foofoofoo" (s/repeat "foo" 3)))) - -(deftest t-reverse - (is (= "tab" (s/reverse "bat")))) - -(deftest t-replace - (is (= "faabar" (s/replace "foobar" \o \a))) - (is (= "barbarbar" (s/replace "foobarfoo" "foo" "bar"))) - (is (= "FOObarFOO" (s/replace "foobarfoo" #"foo" s/upper-case)))) - -(deftest t-replace-first - (is (= "barbarfoo" (s/replace-first "foobarfoo" #"foo" "bar"))) - (is (= "FOObarfoo" (s/replace-first "foobarfoo" #"foo" s/upper-case)))) - -(deftest t-partition - (is (= (list "" "abc" "123" "def") - (s/partition "abc123def" #"[a-z]+")))) - -(deftest t-join - (is (= "1,2,3" (s/join \, [1 2 3]))) - (is (= "" (s/join \, []))) - (is (= "1 and-a 2 and-a 3" (s/join " and-a " [1 2 3])))) - -(deftest t-chop - (is (= "fo" (s/chop "foo"))) - (is (= "") (s/chop "f")) - (is (= "") (s/chop ""))) - -(deftest t-chomp - (is (= "foo" (s/chomp "foo\n"))) - (is (= "foo" (s/chomp "foo\r\n"))) - (is (= "foo" (s/chomp "foo"))) - (is (= "" (s/chomp "")))) - -(deftest t-swap-case - (is (= "fOO!bAR" (s/swap-case "Foo!Bar"))) - (is (= "" (s/swap-case "")))) - -(deftest t-capitalize - (is (= "Foobar" (s/capitalize "foobar"))) - (is (= "Foobar" (s/capitalize "FOOBAR")))) - -(deftest t-ltrim - (is (= "foo " (s/ltrim " foo "))) - (is (= "" (s/ltrim " ")))) - -(deftest t-rtrim - (is (= " foo" (s/rtrim " foo "))) - (is (= "" (s/rtrim " ")))) - -(deftest t-split-lines - (is (= (list "one" "two" "three") - (s/split-lines "one\ntwo\r\nthree"))) - (is (= (list "foo") (s/split-lines "foo")))) - -(deftest t-upper-case - (is (= "FOOBAR" (s/upper-case "Foobar")))) - -(deftest t-lower-case - (is (= "foobar" (s/lower-case "FooBar")))) - -(deftest t-trim - (is (= "foo" (s/trim " foo \r\n")))) - -(deftest t-contains - (is (s/contains? "foobar" "foo")) - (is (not (s/contains? "foobar" "baz")))) - -(deftest t-get - (is (= \o (s/get "foo" 1)))) - -(deftest t-partial - (is (= "bar" ((s/partial s/drop 3) "foobar"))) - (is (= "ooba" ((comp (s/partial s/take 4) - (s/partial s/drop 1)) "foobar")))) diff --git a/src/clojure/contrib/test_contrib/test_dataflow.clj b/src/clojure/contrib/test_contrib/test_dataflow.clj deleted file mode 100644 index 8b934dc3..00000000 --- a/src/clojure/contrib/test_contrib/test_dataflow.clj +++ /dev/null @@ -1,90 +0,0 @@ -;; Copyright (c) Jeffrey Straszheim. 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. -;; -;; test-dataflow -;; -;; A Library to Support a Dataflow Model of State - Tests -;; -;; straszheimjeffrey (gmail) -;; Created 11 March 2009 - - -(ns clojure.contrib.test-contrib.test-dataflow - (:use clojure.test) - (:use clojure.contrib.dataflow)) - -(def df-1 - (build-dataflow - [(cell :source base 0) - (cell :source items ()) - (cell product (* ?base (apply + ?items))) - (cell :validator (when (number? ?-product) - (assert (>= ?product ?-product))))])) - -(deftest test-df-1 - (is (= (get-value df-1 'product) 0)) - (is (do (update-values df-1 {'items [4 5]}) - (= (get-value df-1 'product) 0))) - (is (do (update-values df-1 {'base 2}) - (= (get-value df-1 'product) 18))) - (is (thrown? AssertionError (update-values df-1 {'base 0}))) - (is (= (get-value df-1 'product) 18))) - -(def df-2 - (build-dataflow - [(cell :source strength 10) - (cell :source agility 10) - (cell :source magic 10) - - (cell total-cost (apply + ?*cost)) - - (cell cost (- ?strength 10)) - (cell cost (- ?agility 10)) - (cell cost (- ?magic 10)) - - (cell combat (+ ?strength ?agility ?combat-mod)) - (cell speed (+ ?agility (/ ?strength 10.0) ?speed-mod)) - (cell casting (+ ?agility ?magic ?magic-mod)) - - (cell combat-mod (apply + ?*combat-mods)) - (cell speed-mod (apply + ?*speed-mods)) - (cell magic-mod (apply + ?*magic-mods))])) - -(def magic-skill - [(cell cost 5) - (cell speed-mods 1) - (cell magic-mods 2)]) - -(defn gv [n] (get-value df-2 n)) - -(deftest test-df-2 - (is (and (= (gv 'total-cost) 0) - (= (gv 'strength) 10) - (= (gv 'casting) 20))) - (is (do (update-values df-2 {'magic 12}) - (and (= (gv 'total-cost) 2) - (= (gv 'casting) 22)))) - (is (do (add-cells df-2 magic-skill) - (and (= (gv 'total-cost) 7) - (= (gv 'casting) 24)))) - (is (do (remove-cells df-2 magic-skill) - (and (= (gv 'total-cost) 2) - (= (gv 'casting) 22))))) - - -(comment - (run-tests) - - (use :reload 'clojure.contrib.dataflow) - (use 'clojure.contrib.stacktrace) (e) - (use 'clojure.contrib.trace) - -) - - -;; End of file diff --git a/src/clojure/contrib/test_contrib/test_graph.clj b/src/clojure/contrib/test_contrib/test_graph.clj deleted file mode 100644 index ed03b9ae..00000000 --- a/src/clojure/contrib/test_contrib/test_graph.clj +++ /dev/null @@ -1,187 +0,0 @@ -;; Copyright (c) Jeffrey Straszheim. 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. -;; -;; test-graph -;; -;; Basic Graph Theory Algorithms Tests -;; -;; straszheimjeffrey (gmail) -;; Created 23 June 2009 - -(ns clojure.contrib.test-contrib.test-graph - (use clojure.test - clojure.contrib.graph)) - - -(def empty-graph (struct directed-graph #{} {})) - -(def test-graph-1 - (struct directed-graph - #{:a :b :c :d :e} - {:a #{:b :c} - :b #{:a :c} - :c #{:d :e} - :d #{:a :b} - :e #{:d}})) - -(deftest test-reverse-graph - (is (= (reverse-graph test-graph-1) - (struct directed-graph - #{:a :b :c :d :e} - {:c #{:b :a} - :e #{:c} - :d #{:c :e} - :b #{:d :a} - :a #{:d :b}}))) - (is (= (reverse-graph (reverse-graph test-graph-1)) - test-graph-1)) - (is (= (reverse-graph empty-graph) empty-graph))) - -(deftest test-add-loops - (let [tg1 (add-loops test-graph-1)] - (is (every? (fn [n] (contains? (get-neighbors tg1 n) n)) (:nodes tg1)))) - (is (= (add-loops empty-graph) empty-graph))) - -(deftest test-remove-loops - (let [tg1 (remove-loops (add-loops test-graph-1))] - (is (not-any? (fn [n] (contains? (get-neighbors tg1 n) n)) (:nodes tg1)))) - (is (= (remove-loops empty-graph) empty-graph))) - - -(def test-graph-2 - (struct directed-graph - #{:a :b :c :d :e :f :g :h :i :j} - {:a #{:b :c} - :b #{:a :c} - :c #{:d :e} - :d #{:a :b} - :e #{:d} - :f #{:f} - :g #{:a :f} - :h #{} - :i #{:j} - :j #{:i}})) - - -(deftest test-lazy-walk - (is (= (lazy-walk test-graph-2 :h) [:h])) - (is (= (lazy-walk test-graph-2 :j) [:j :i]))) - -(deftest test-transitive-closure - (let [tc-1 (transitive-closure test-graph-1) - tc-2 (transitive-closure test-graph-2) - get (fn [n] (set (get-neighbors tc-2 n)))] - (is (every? #(= #{:a :b :c :d :e} (set %)) - (map (partial get-neighbors tc-1) (:nodes tc-1)))) - (is (= (get :a) #{:a :b :c :d :e})) - (is (= (get :h) #{})) - (is (= (get :j) #{:i :j})) - (is (= (get :g) #{:a :b :c :d :e :f})))) - - -(deftest test-post-ordered-nodes - (is (= (set (post-ordered-nodes test-graph-2)) - #{:a :b :c :d :e :f :g :h :i :j})) - (is (empty? (post-ordered-nodes empty-graph)))) - - -(deftest test-scc - (is (= (set (scc test-graph-2)) - #{#{:h} #{:g} #{:i :j} #{:b :c :a :d :e} #{:f}})) - (is (empty? (scc empty-graph)))) - -(deftest test-component-graph - (let [cg (component-graph test-graph-2) - ecg (component-graph empty-graph)] - (is (= (:nodes cg) (set (scc test-graph-2)))) - (is (= (get-neighbors cg #{:a :b :c :d :e}) - #{#{:a :b :c :d :e}})) - (is (= (get-neighbors cg #{:g}) - #{#{:a :b :c :d :e} #{:f}})) - (is (= (get-neighbors cg #{:i :j}) - #{#{:i :j}})) - (is (= (get-neighbors cg #{:h}) - #{})) - (is (= (apply max (map count (self-recursive-sets cg))) 1)) - (is (= ecg empty-graph)))) - - -(deftest test-recursive-component? - (let [sccs (scc test-graph-2)] - (is (= (set (filter (partial recursive-component? test-graph-2) sccs)) - #{#{:i :j} #{:b :c :a :d :e} #{:f}})))) - - -(deftest test-self-recursive-sets - (is (= (set (self-recursive-sets test-graph-2)) - (set (filter - (partial recursive-component? test-graph-2) - (scc test-graph-2))))) - (is (empty? (self-recursive-sets empty-graph)))) - - -(def test-graph-3 - (struct directed-graph - #{:a :b :c :d :e :f} - {:a #{:b} - :b #{:c} - :c #{:d} - :d #{:e} - :e #{:f} - :f #{}})) - -(def test-graph-4 - (struct directed-graph - #{:a :b :c :d :e :f :g :h} - {:a #{} - :b #{:a} - :c #{:a} - :d #{:a :b} - :e #{:d :c} - :f #{:e} - :g #{:d} - :h #{:f}})) - -(def test-graph-5 - (struct directed-graph - #{:a :b :c :d :e :f :g :h} - {:a #{} - :b #{} - :c #{:b} - :d #{} - :e #{} - :f #{} - :g #{:f} - :h #{}})) - -(deftest test-dependency-list - (is (thrown-with-msg? Exception #".*Fixed point overflow.*" - (dependency-list test-graph-2))) - (is (= (dependency-list test-graph-3) - [#{:f} #{:e} #{:d} #{:c} #{:b} #{:a}])) - (is (= (dependency-list test-graph-4) - [#{:a} #{:b :c} #{:d} #{:g :e} #{:f} #{:h}])) - (is (= (dependency-list test-graph-5) - [#{:f :b :a :d :h :e} #{:g :c}])) - (is (= (dependency-list empty-graph) - [#{}]))) - -(deftest test-stratification-list - (is (thrown-with-msg? Exception #".*Fixed point overflow.*" - (stratification-list test-graph-2 test-graph-2))) - (is (= (stratification-list test-graph-4 test-graph-5) - [#{:a} #{:b :c} #{:d} #{:e} #{:f :g} #{:h}])) - (is (= (stratification-list empty-graph empty-graph) - [#{}]))) - -(comment - (run-tests) -) - - -;; End of file diff --git a/src/clojure/contrib/test_contrib/test_java_utils.clj b/src/clojure/contrib/test_contrib/test_java_utils.clj deleted file mode 100644 index 8e0f67c4..00000000 --- a/src/clojure/contrib/test_contrib/test_java_utils.clj +++ /dev/null @@ -1,123 +0,0 @@ -(ns clojure.contrib.test-contrib.test-java-utils - (:use clojure.test - [clojure.contrib.duck-streams :only (spit)] - clojure.contrib.java-utils) - (:import [java.io File] - [java.net URL URI] - [java.util Properties])) - -(deftest test-relative-path-string - (testing "strings" - (is (= "foo" (relative-path-string "foo")))) - (testing "absolute path strings are forbidden" - (is (thrown? IllegalArgumentException (relative-path-string "/baz")))) - (testing "relative File paths" - (is (= "bar" (relative-path-string (File. "bar"))))) - (testing "absolute File paths are forbidden" - (is (thrown? IllegalArgumentException (relative-path-string (File. "/quux"))))) -) - -(deftest test-as-file - (testing "strings" - (is (= (File. "foo") (as-file "foo")))) - (testing "Files" - (is (= (File. "bar") (as-file (File. "bar"))))) -) - -(deftest test-as-url - (are [result expr] (= result expr) - (URL. "http://foo") (as-url (URL. "http://foo")) - (URL. "http://foo") (as-url "http://foo") - (URL. "http://foo") (as-url (URI. "http://foo")) - (URL. "file:/foo") (as-url (File. "/foo")))) - -(deftest test-file - (testing "single argument" - (is (= (File. "foo") (file "foo")))) - (testing "two arguments" - (is (= (File. "foo/bar") (file "foo" "bar")))) - (testing "N arguments" - (is (= (File. "foo/bar/baz/quux") (file "foo" "bar" "baz" "quux")))) - (testing "no sneaking in absolute paths!" - (is (thrown? IllegalArgumentException (file "foo" "bar" "/boom" "baz" "quux")))) -) - -(deftest test-as-str - (testing "keyword to string" - (is (= "foo") (as-str :foo))) - (testing "symbol to string" - (is (= "foo") (as-str 'foo))) - (testing "string to string" - (is (= "foo") (as-str "foo"))) - (testing "stringifying non-namish things" - (is (= "42") (as-str 42))) -) - -(deftest test-get-system-property - (testing "works the same with keywords, symbols, and strings" - (is (= (get-system-property "java.home") (get-system-property 'java.home))) - (is (= (get-system-property "java.home") (get-system-property :java.home)))) - (testing "treats second arg as default" - (is (= "default" (get-system-property "testing.test-system-property" "default")))) - (testing "returns nil for missing properties" - (is (nil? (get-system-property "testing.test-system-property")))) -) - -(deftest test-set-system-properties - (testing "set and then unset a property using keywords" - (let [propname :clojure.contrib.java-utils.test-set-system-properties] - (is (nil? (get-system-property propname))) - (set-system-properties {propname :foo}) - (is (= "foo") (get-system-property propname)) - (set-system-properties {propname nil}) - (is (nil? (get-system-property propname))))) -) - -(deftest test-with-system-properties - (let [propname :clojure.contrib.java-utils.test-with-system-properties] - (testing "sets a property only for the duration of a block" - (is (= "foo" - (with-system-properties {propname "foo"} - (get-system-property propname)))) - (is (nil? (get-system-property propname))))) - (testing "leaves other properties alone" - ; TODO: write this test better, using a properties -> map function - (let [propname :clojure.contrib.java-utils.test-with-system-properties - propcount (count (System/getProperties))] - (with-system-properties {propname "foo"} - (is (= (inc propcount) (count (System/getProperties))))) - (is (= propcount (count (System/getProperties)))))) -) - -(deftest test-as-properties - (let [expected (doto (Properties.) - (.setProperty "a" "b") - (.setProperty "c" "d"))] - (testing "with a map" - (is (= expected - (as-properties {:a "b" :c "d"})))) - (testing "with a sequence of pairs" - (is (= expected - (as-properties [[:a :b] [:c :d]])))))) - -(deftest test-read-properties - (let [f (File/createTempFile "test" "properties")] - (spit f "a=b\nc=d") - (is (= {"a" "b" "c" "d"} - (read-properties f))))) - -(deftest test-write-properties - (let [f (File/createTempFile "test" "properties")] - (write-properties [['a 'b] ['c 'd]] f) - (is (= {"a" "b" "c" "d"} - (read-properties f))))) - - -(deftest test-delete-file - (let [file (File/createTempFile "test" "deletion") - not-file (File. (str (java.util.UUID/randomUUID)))] - (delete-file (.getAbsolutePath file)) - (is (not (.exists file))) - (is (thrown? ArithmeticException (/ 1 0))) - (is (thrown? java.io.IOException (delete-file not-file))) - (is (delete-file not-file :silently)))) diff --git a/src/clojure/contrib/test_contrib/test_jmx.clj b/src/clojure/contrib/test_contrib/test_jmx.clj deleted file mode 100644 index f75c76bf..00000000 --- a/src/clojure/contrib/test_contrib/test_jmx.clj +++ /dev/null @@ -1,166 +0,0 @@ -;; Tests for JMX support for Clojure (see also 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. - -(ns clojure.contrib.test-contrib.test-jmx - (:import javax.management.openmbean.CompositeDataSupport - [javax.management MBeanAttributeInfo AttributeList] - [java.util.logging LogManager Logger] - clojure.contrib.jmx.Bean) - (:use clojure.test) - (:require [clojure.contrib [jmx :as jmx]])) - - -(defn =set [a b] - (= (set a) (set b))) - -(deftest finding-mbeans - (testing "as-object-name" - (are [cname object-name] - (= cname (.getCanonicalName object-name)) - "java.lang:type=Memory" (jmx/as-object-name "java.lang:type=Memory"))) - (testing "mbean-names" - (are [cnames object-name] - (= cnames (map #(.getCanonicalName %) object-name)) - ["java.lang:type=Memory"] (jmx/mbean-names "java.lang:type=Memory")))) - -; don't know which attributes are common on all JVM platforms. May -; need to change expectations. -(deftest reflecting-on-capabilities - (are [attr-list mbean-name] - (= (set attr-list) (set (jmx/attribute-names mbean-name))) - [:Verbose :ObjectPendingFinalizationCount :HeapMemoryUsage :NonHeapMemoryUsage] "java.lang:type=Memory") - (are [a b] - (= (set a) (set b)) - [:gc] (jmx/operation-names "java.lang:type=Memory"))) - -(deftest raw-reading-attributes - (let [mem "java.lang:type=Memory" - log "java.util.logging:type=Logging"] - (testing "simple scalar attributes" - (are [a b] (= a b) - false (jmx/raw-read mem :Verbose)) - (are [type attr] (instance? type attr) - Integer (jmx/raw-read mem :ObjectPendingFinalizationCount))))) - -(deftest reading-attributes - (testing "simple scalar attributes" - (are [type attr] (instance? type attr) - Integer (jmx/read "java.lang:type=Memory" :ObjectPendingFinalizationCount))) - (testing "composite attributes" - (are [ks attr] (=set ks (keys attr)) - [:used :max :init :committed] (jmx/read "java.lang:type=Memory" :HeapMemoryUsage))) - (testing "tabular attributes" - (is (map? (jmx/read "java.lang:type=Runtime" :SystemProperties))))) - -(deftest mbean-from-oname - (are [oname key-names] - (= (set key-names) (set (keys (jmx/mbean oname)))) - "java.lang:type=Memory" [:Verbose :ObjectPendingFinalizationCount :HeapMemoryUsage :NonHeapMemoryUsage])) - -(deftest writing-attributes - (let [mem "java.lang:type=Memory"] - (jmx/write! mem :Verbose true) - (is (true? (jmx/raw-read mem :Verbose))) - (jmx/write! mem :Verbose false))) - -(deftest test-invoke-operations - (testing "without arguments" - (jmx/invoke "java.lang:type=Memory" :gc)) - (testing "with arguments" - (.addLogger (LogManager/getLogManager) (Logger/getLogger "clojure.contrib.test_contrib.test_jmx")) - (jmx/invoke "java.util.logging:type=Logging" :setLoggerLevel "clojure.contrib.test_contrib.test_jmx" "WARNING"))) - -(deftest test-jmx->clj - (testing "it works recursively on maps" - (let [some-map {:foo (jmx/raw-read "java.lang:type=Memory" :HeapMemoryUsage)}] - (is (map? (:foo (jmx/jmx->clj some-map)))))) - (testing "it leaves everything else untouched" - (is (= "foo" (jmx/jmx->clj "foo"))))) - - -(deftest test-composite-data->map - (let [data (jmx/raw-read "java.lang:type=Memory" :HeapMemoryUsage) - prox (jmx/composite-data->map data)] - (testing "returns a map with keyword keys" - (is (= (set [:committed :init :max :used]) (set (keys prox))))))) - -(deftest test-tabular-data->map - (let [raw-props (jmx/raw-read "java.lang:type=Runtime" :SystemProperties) - props (jmx/tabular-data->map raw-props)] - (are [k] (contains? props k) - :java.class.path - :path.separator))) - -(deftest test-creating-attribute-infos - (let [infos (jmx/map->attribute-infos [[:a 1] [:b 2]]) - info (first infos)] - (testing "generates the right class" - (is (= (class (into-array MBeanAttributeInfo [])) (class infos)))) - (testing "generates the right instance data" - (are [result expr] (= result expr) - "a" (.getName info) - "a" (.getDescription info))))) - -(deftest various-beans-are-readable - (testing "that all java.lang beans can be read without error" - (doseq [mb (jmx/mbean-names "*:*")] - (jmx/mbean mb)))) - -(deftest test-jmx-url - (testing "creates default url" - (is (= "service:jmx:rmi:///jndi/rmi://localhost:3000/jmxrmi" (jmx/jmx-url)))) - (testing "creates custom url" - (is (= "service:jmx:rmi:///jndi/rmi://example.com:4000/jmxrmi" (jmx/jmx-url {:host "example.com" :port 4000}))))) - -;; ---------------------------------------------------------------------- -;; tests for clojure.contrib.jmx.Bean. - -(deftest dynamic-mbean-from-compiled-class - (let [mbean-name "clojure.contrib.test_contrib.test_jmx:name=Foo"] - (jmx/register-mbean - (Bean. - (ref {:string-attribute "a-string"})) - mbean-name) - (are [result expr] (= result expr) - "a-string" (jmx/read mbean-name :string-attribute) - {:string-attribute "a-string"} (jmx/mbean mbean-name) - ))) - -(deftest test-getAttribute - (doseq [reftype [ref atom agent]] - (let [state (reftype {:a 1 :b 2}) - bean (Bean. state)] - (testing (str "accessing values from a " (class state)) - (are [result expr] (= result expr) - 1 (.getAttribute bean "a")))))) - -(deftest test-bean-info - (let [state (ref {:a 1 :b 2}) - bean (Bean. state) - info (.getMBeanInfo bean)] - (testing "accessing info" - (are [result expr] (= result expr) - "clojure.contrib.jmx.Bean" (.getClassName info))))) - -(deftest test-getAttributes - (let [bean (Bean. (ref {:r 5 :d 4})) - atts (.getAttributes bean (into-array ["r" "d"]))] - (are [x y] (= x y) - AttributeList (class atts) - [5 4] (seq atts)))) - -(deftest test-guess-attribute-typename - (are [x y] (= x (jmx/guess-attribute-typename y)) - "int" 10 - "boolean" false - "java.lang.String" "foo" - "long" (long 10)))
\ No newline at end of file diff --git a/src/clojure/contrib/test_contrib/test_lazy_seqs.clj b/src/clojure/contrib/test_contrib/test_lazy_seqs.clj deleted file mode 100644 index 33bbcae1..00000000 --- a/src/clojure/contrib/test_contrib/test_lazy_seqs.clj +++ /dev/null @@ -1,21 +0,0 @@ -(ns clojure.contrib.test-contrib.test-lazy-seqs - (:use clojure.test - clojure.contrib.lazy-seqs)) - -(deftest test-fibs - (is (= [0 1 1 2 3 5 8 13 21 34 55 89 144 233 377 610 987 1597 2584 4181 6765 10946 - 17711 28657 46368 75025 121393 196418 317811 514229 832040 1346269 2178309 - 3524578 5702887 9227465 14930352 24157817 39088169 63245986 102334155 - 165580141 267914296 433494437 701408733 1134903170 1836311903 2971215073 - 4807526976 7778742049] - (take 50 (fibs))))) - -(deftest test-powers-of-2 - (is (= [1 2 4 8 16 32 64 128 256 512] - (take 10 (powers-of-2))))) - -(deftest test-primes - (is (= [2 3 5 7 11 13 17 19 23 29 31 37 41 43 47 53 59 61 67 71 73 79 83 89 97 101 - 103 107 109 113 127 131 137 139 149 151 157 163 167 173 179 181 191 193 197 - 199 211 223 227 229] - (take 50 primes)))) diff --git a/src/clojure/contrib/test_contrib/test_trace.clj b/src/clojure/contrib/test_contrib/test_trace.clj deleted file mode 100644 index 32c2ccbe..00000000 --- a/src/clojure/contrib/test_contrib/test_trace.clj +++ /dev/null @@ -1,16 +0,0 @@ -(ns clojure.contrib.test-contrib.test-trace - (:use clojure.test - [clojure.contrib trace str-utils])) - -(deftrace call-myself [n] - (when-not (< n 1) - (call-myself (dec n)))) - -(deftest test-tracing-a-function-that-calls-itself - (let [output (with-out-str (call-myself 1))] - (is (re-find #"^TRACE t\d+: (call-myself 1)\nTRACE t\d+: | (call-myself 0)\nTRACE t\d+: | => nil\nTRACE t\d+: => nil$" - output)))) - -;(deftest dotrace-on-core -; (let [output (with-out-str (dotrace [mod] (mod 11 5)))] -; (is (re-find #"\(mod 11 5\)" output)))) diff --git a/src/clojure/contrib/test_contrib/walk.clj b/src/clojure/contrib/test_contrib/walk.clj deleted file mode 100644 index 9e79f8d6..00000000 --- a/src/clojure/contrib/test_contrib/walk.clj +++ /dev/null @@ -1,34 +0,0 @@ -(ns clojure.contrib.test-contrib.walk - (:require [clojure.contrib.walk :as w]) - (:use clojure.test)) - -(deftest t-prewalk-replace - (is (= (w/prewalk-replace {:a :b} [:a {:a :a} (list 3 :c :a)]) - [:b {:b :b} (list 3 :c :b)]))) - -(deftest t-postwalk-replace - (is (= (w/postwalk-replace {:a :b} [:a {:a :a} (list 3 :c :a)]) - [:b {:b :b} (list 3 :c :b)]))) - -(deftest t-stringify-keys - (is (= (w/stringify-keys {:a 1, nil {:b 2 :c 3}, :d 4}) - {"a" 1, nil {"b" 2 "c" 3}, "d" 4}))) - -(deftest t-prewalk-order - (is (= (let [a (atom [])] - (w/prewalk (fn [form] (swap! a conj form) form) - [1 2 {:a 3} (list 4 [5])]) - @a) - [[1 2 {:a 3} (list 4 [5])] - 1 2 {:a 3} [:a 3] :a 3 (list 4 [5]) - 4 [5] 5]))) - -(deftest t-postwalk-order - (is (= (let [a (atom [])] - (w/postwalk (fn [form] (swap! a conj form) form) - [1 2 {:a 3} (list 4 [5])]) - @a) - [1 2 - :a 3 [:a 3] {:a 3} - 4 5 [5] (list 4 [5]) - [1 2 {:a 3} (list 4 [5])]])))
\ No newline at end of file diff --git a/src/clojure/contrib/test_contrib/with_ns_test.clj b/src/clojure/contrib/test_contrib/with_ns_test.clj deleted file mode 100644 index 09137bc0..00000000 --- a/src/clojure/contrib/test_contrib/with_ns_test.clj +++ /dev/null @@ -1,19 +0,0 @@ -(ns clojure.contrib.test-contrib.with-ns-test - (:use clojure.test - clojure.contrib.with-ns - [clojure.contrib.seq-utils :only (includes?)])) - -(deftest test-namespace-gets-removed - (let [all-ns-names (fn [] (map #(.name %) (all-ns)))] - (testing "unexceptional return" - (let [ns-name (with-temp-ns (ns-name *ns*))] - (is (not (includes? (all-ns-names) ns-name))))) - (testing "when an exception is thrown" - (let [ns-name-str - (try - (with-temp-ns - (throw (RuntimeException. (str (ns-name *ns*))))) - (catch clojure.lang.Compiler$CompilerException e - (-> e .getCause .getMessage)))] - (is (re-find #"^sym.*$" ns-name-str)) - (is (not (includes? (all-ns-names) (symbol ns-name-str)))))))) diff --git a/src/clojure/contrib/test_is.clj b/src/clojure/contrib/test_is.clj deleted file mode 100644 index 62666b62..00000000 --- a/src/clojure/contrib/test_is.clj +++ /dev/null @@ -1,118 +0,0 @@ -;;; test_is.clj: Compatibility layer for old clojure.contrib.test-is - -;; by Stuart Sierra, http://stuartsierra.com/ -;; August 28, 2009 - -;; Copyright (c) Stuart Sierra, 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. - - - -(ns #^{:doc "Backwards-compatibility for clojure.contrib.test-is - - The clojure.contrib.test-is library moved from Contrib into the - Clojure distribution as clojure.test. - - This happened on or around clojure-contrib Git commit - 82cf0409d0fcb71be477ebfc4da18ee2128a2ad1 on June 25, 2009. - - This file makes the clojure.test interface available under the old - namespace clojure.contrib.test-is. - - This includes support for the old syntax of the 'are' macro. - - This was suggested by Howard Lewis Ship in ticket #26, - http://www.assembla.com/spaces/clojure-contrib/tickets/26" - :author "Stuart Sierra"} - clojure.contrib.test-is - (:require clojure.test - [clojure.walk :as walk])) - - -;;; COPY INTERNED VARS (EXCEPT are) FROM clojure.test - -(doseq [v (disj (set (vals (ns-interns 'clojure.test))) - #'clojure.test/are)] - (intern *ns* (with-meta (:name (meta v)) (meta v)) (var-get v))) - - -;;; REDEFINE OLD clojure.contrib.template - -(defn find-symbols - "Recursively finds all symbols in form." - [form] - (distinct (filter symbol? (tree-seq coll? seq form)))) - -(defn find-holes - "Recursively finds all symbols starting with _ in form." - [form] - (sort (distinct (filter #(.startsWith (name %) "_") - (find-symbols form))))) - -(defn find-pure-exprs - "Recursively finds all sub-expressions in form that do not contain - any symbols starting with _" - [form] - (filter #(and (list? %) - (empty? (find-holes %))) - (tree-seq seq? seq form))) - -(defn flatten-map - "Transforms a map into a vector like [key value key value]." - [m] - (reduce (fn [coll [k v]] (conj coll k v)) - [] m)) - -(defn template? - "Returns true if form is a valid template expression." - [form] - (if (seq (find-holes form)) true false)) - -(defn apply-template - "Replaces _1, _2, _3, etc. in expr with corresponding elements of - values. Returns the modified expression. For use in macros." - [expr values] - (when-not (template? expr) - (throw (IllegalArgumentException. (str (pr-str expr) " is not a valid template.")))) - (let [expr (walk/postwalk-replace {'_ '_1} expr) - holes (find-holes expr) - smap (zipmap holes values)] - (walk/prewalk-replace smap expr))) - -(defmacro do-template - "Repeatedly evaluates template expr (in a do block) using values in - args. args are grouped by the number of holes in the template. - Example: (do-template (check _1 _2) :a :b :c :d) - expands to (do (check :a :b) (check :c :d))" - [expr & args] - (when-not (template? expr) - (throw (IllegalArgumentException. (str (pr-str expr) " is not a valid template.")))) - (let [expr (walk/postwalk-replace {'_ '_1} expr) - argcount (count (find-holes expr))] - `(do ~@(map (fn [a] (apply-template expr a)) - (partition argcount args))))) - - - -;;; REDEFINE are MACRO TO MATCH OLD TEMPLATE BEHAVIOR - -(defmacro are - "Checks multiple assertions with a template expression. - See clojure.contrib.template/do-template for an explanation of - templates. - - Example: (are (= _1 _2) - 2 (+ 1 1) - 4 (* 2 2)) - Expands to: - (do (is (= 2 (+ 1 1))) - (is (= 4 (* 2 2)))) - - Note: This breaks some reporting features, such as line numbers." - [expr & args] - `(do-template (is ~expr) ~@args)) diff --git a/src/clojure/contrib/trace.clj b/src/clojure/contrib/trace.clj deleted file mode 100644 index ccfc5ef1..00000000 --- a/src/clojure/contrib/trace.clj +++ /dev/null @@ -1,98 +0,0 @@ -;;; trace.clj -- simple call-tracing macros for Clojure - -;; by Stuart Sierra, http://stuartsierra.com/ -;; December 3, 2008 - -;; Copyright (c) Stuart Sierra, 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 file defines simple "tracing" macros to help you see what your -;; code is doing. - - -;; CHANGE LOG -;; -;; December 3, 2008: -;; -;; * replaced *trace-out* with tracer -;; -;; * made trace a function instead of a macro -;; (suggestion from Stuart Halloway) -;; -;; * added trace-fn-call -;; -;; June 9, 2008: first version - - - -(ns - #^{:author "Stuart Sierra, Michel Salim", - :doc "This file defines simple \"tracing\" macros to help you see what your -code is doing."} - clojure.contrib.trace) - -(def - #^{:doc "Current stack depth of traced function calls."} - *trace-depth* 0) - -(defn tracer - "This function is called by trace. Prints to standard output, but - may be rebound to do anything you like. 'name' is optional." - [name value] - (println (str "TRACE" (when name (str " " name)) ": " value))) - -(defn trace - "Sends name (optional) and value to the tracer function, then - returns value. May be wrapped around any expression without - affecting the result." - ([value] (trace nil value)) - ([name value] - (tracer name (pr-str value)) - value)) - -(defn trace-indent - "Returns an indentation string based on *trace-depth*" - [] - (apply str (take *trace-depth* (repeat "| ")))) - -(defn trace-fn-call - "Traces a single call to a function f with args. 'name' is the - symbol name of the function." - [name f args] - (let [id (gensym "t")] - (tracer id (str (trace-indent) (pr-str (cons name args)))) - (let [value (binding [*trace-depth* (inc *trace-depth*)] - (apply f args))] - (tracer id (str (trace-indent) "=> " (pr-str value))) - value))) - -(defmacro deftrace - "Use in place of defn; traces each call/return of this fn, including - arguments. Nested calls to deftrace'd functions will print a - tree-like structure." - [name & definition] - `(do - (def ~name) - (let [f# (fn ~@definition)] - (defn ~name [& args#] - (trace-fn-call '~name f# args#))))) - -(defmacro dotrace - "Given a sequence of function identifiers, evaluate the body - expressions in an environment in which the identifiers are bound to - the traced functions. Does not work on inlined functions, - such as clojure.core/+" - [fns & exprs] - (if (empty? fns) - `(do ~@exprs) - (let [func (first fns) - fns (next fns)] - `(let [f# ~func] - (binding [~func (fn [& args#] (trace-fn-call '~func f# args#))] - (dotrace ~fns ~@exprs)))))) diff --git a/src/clojure/contrib/types.clj b/src/clojure/contrib/types.clj deleted file mode 100644 index f0b85267..00000000 --- a/src/clojure/contrib/types.clj +++ /dev/null @@ -1,275 +0,0 @@ -;; Data types - -;; by Konrad Hinsen -;; last updated May 3, 2009 - -;; Copyright (c) Konrad Hinsen, 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. - -(ns - #^{:author "Konrad Hinsen" - :doc "General and algebraic data types"} - clojure.contrib.types - (:refer-clojure :exclude (deftype)) - (:use [clojure.contrib.def :only (name-with-attributes)])) - -; -; Utility functions -; -(defn- qualified-symbol - [s] - (symbol (str *ns*) (str s))) - -(defn- qualified-keyword - [s] - (keyword (str *ns*) (str s))) - -(defn- unqualified-symbol - [s] - (let [s-str (str s)] - (symbol (subs s-str (inc (.indexOf s-str (int \/))))))) - -(defn- resolve-symbol - [s] - (if-let [var (resolve s)] - (symbol (str (.ns var)) (str (.sym var))) - s)) - -; -; Data type definition -; -(defmulti deconstruct type) - -(defmulti constructor-form type) -(defmethod constructor-form :default - [o] nil) -(defmethod constructor-form ::type - [o] (cons (::constructor (meta o)) (deconstruct o))) - -(defmacro deftype - "Define a data type by a type tag (a namespace-qualified keyword) - and a symbol naming the constructor function. Optionally, a - constructor and a deconstructor function can be given as well, - the defaults being clojure.core/identity and clojure.core/list. - The full constructor associated with constructor-name calls the - constructor function and attaches the type tag to its result - as metadata. The deconstructor function must return the arguments - to be passed to the constructor in order to create an equivalent - object. It is used for printing and matching." - {:arglists - '([type-tag constructor-name docstring? attr-map?] - [type-tag constructor-name docstring? attr-map? constructor] - [type-tag constructor-name docstring? attr-map? constructor deconstructor])} - [type-tag constructor-name & options] - (let [[constructor-name options] (name-with-attributes - constructor-name options) - [constructor deconstructor] options - constructor (if (nil? constructor) - 'clojure.core/identity - constructor) - deconstructor (if (nil? deconstructor) - 'clojure.core/list - deconstructor)] - `(do - (derive ~type-tag ::type) - (let [meta-map# {:type ~type-tag - ::constructor - (quote ~(qualified-symbol constructor-name))}] - (def ~constructor-name - (comp (fn [~'x] (with-meta ~'x meta-map#)) ~constructor)) - (defmethod deconstruct ~type-tag [~'x] - (~deconstructor (with-meta ~'x {}))))))) - -(defmacro deftype- - "Same as deftype but the constructor is private." - [type-tag constructor-name & optional] - `(deftype ~type-tag - ~(vary-meta constructor-name assoc :private true) - ~@optional)) - -(defmethod print-method ::type [o w] - (let [cf (constructor-form o)] - (if (symbol? cf) - (print-method (unqualified-symbol cf) w) - (print-method (cons (unqualified-symbol (first cf)) (rest cf)) w)))) - -; -; Algebraic types -; -(derive ::adt ::type) - -(defmethod constructor-form ::adt - [o] - (let [v (vals o)] - (if (= 1 (count v)) - (first v) - v))) - -(defn- constructor-code - [meta-map-symbol constructor] - (if (symbol? constructor) - `(def ~constructor - (with-meta {::tag (quote ~(qualified-symbol constructor))} - ~meta-map-symbol)) - (let [[name & args] constructor - keys (cons ::tag (map (comp keyword str) args))] - (if (empty? args) - (throw (IllegalArgumentException. "zero argument constructor")) - `(let [~'basis (create-struct ~@keys)] - (defn ~name ~(vec args) - (with-meta (struct ~'basis (quote ~(qualified-symbol name)) ~@args) - ~meta-map-symbol))))))) - -(defmacro defadt - "Define an algebraic data type name by an exhaustive list of constructors. - Each constructor can be a symbol (argument-free constructor) or a - list consisting of a tag symbol followed by the argument symbols. - The data type tag must be a keyword." - [type-tag & constructors] - (let [meta-map-symbol (gensym "mm")] - `(let [~meta-map-symbol {:type ~type-tag}] - (derive ~type-tag ::adt) - ~@(map (partial constructor-code meta-map-symbol) constructors) - ))) - -; -; Matching templates -; -(defn- symbol-tests-and-bindings - [template vsymbol] - [`(= (quote ~(resolve-symbol template)) ~vsymbol) - []]) - -(defn- sequential-tests-and-bindings - [template vsymbol] - (let [enum-values (map list template (range (count template))) - ; Non-symbols in the template create an equality test with the - ; corresponding value in the object's value list - tests (map (fn [[v i]] `(= ~v (nth ~vsymbol ~i))) - (filter (complement #(symbol? (first %))) enum-values)) - ; Symbols in the template become bindings to the corresponding - ; value in the object. However, if a symbol occurs more than once, - ; only one binding is generated, and equality tests are added - ; for the other values. - bindings (reduce (fn [map [symbol index]] - (assoc map symbol - (conj (get map symbol []) index))) - {} - (filter #(symbol? (first %)) enum-values)) - tests (concat tests - (map (fn [[symbol indices]] - (cons `= (map #(list `nth vsymbol %) indices))) - (filter #(> (count (second %)) 1) bindings))) - bindings (mapcat (fn [[symbol indices]] - [symbol (list `nth vsymbol (first indices))]) - bindings)] - [tests (vec bindings)])) - -(defn- constr-tests-and-bindings - [template cfsymbol] - (let [[tag & values] template - cfasymbol (gensym) - [tests bindings] (sequential-tests-and-bindings values cfasymbol) - argtests (if (empty? tests) - tests - `((let [~cfasymbol (rest ~cfsymbol)] ~@tests)))] - [`(and (seq? ~cfsymbol) - (= (quote ~(resolve-symbol tag)) (first ~cfsymbol)) - ~@argtests) - `[~cfasymbol (rest ~cfsymbol) ~@bindings]])) - -(defn- list-tests-and-bindings - [template vsymbol] - (let [[tests bindings] (sequential-tests-and-bindings template vsymbol)] - [`(and (list? ~vsymbol) ~@tests) - bindings])) - -(defn- vector-tests-and-bindings - [template vsymbol] - (let [[tests bindings] (sequential-tests-and-bindings template vsymbol)] - [`(and (vector? ~vsymbol) ~@tests) - bindings])) - -(defn- map-tests-and-bindings - [template vsymbol] - (let [; First test if the given keys are all present. - tests (map (fn [[k v]] `(contains? ~vsymbol ~k)) template) - ; Non-symbols in the template create an equality test with the - ; corresponding value in the object's value list. - tests (concat tests - (map (fn [[k v]] `(= ~v (~k ~vsymbol))) - (filter (complement #(symbol? (second %))) template))) - ; Symbols in the template become bindings to the corresponding - ; value in the object. However, if a symbol occurs more than once, - ; only one binding is generated, and equality tests are added - ; for the other values. - bindings (reduce (fn [map [key symbol]] - (assoc map symbol - (conj (get map symbol []) key))) - {} - (filter #(symbol? (second %)) template)) - tests (concat tests - (map (fn [[symbol keys]] - (cons `= (map #(list % vsymbol) keys))) - (filter #(> (count (second %)) 1) bindings))) - bindings (mapcat (fn [[symbol keys]] - [symbol (list (first keys) vsymbol)]) - bindings)] - [`(and (map? ~vsymbol) ~@tests) - (vec bindings)])) - -(defn- tests-and-bindings - [template vsymbol cfsymbol] - (cond (symbol? template) - (symbol-tests-and-bindings template cfsymbol) - (seq? template) - (if (= (first template) 'quote) - (list-tests-and-bindings (second template) vsymbol) - (constr-tests-and-bindings template cfsymbol)) - (vector? template) - (vector-tests-and-bindings template vsymbol) - (map? template) - (map-tests-and-bindings template vsymbol) - :else - (throw (IllegalArgumentException. "illegal template for match")))) - -(defmacro match - "Given a value and a list of template-expr clauses, evaluate the first - expr whose template matches the value. There are four kinds of templates: - 1) Lists of the form (tag x1 x2 ...) match instances of types - whose constructor has the same form as the list. - 2) Quoted lists of the form '(x1 x2 ...) match lists of the same - length. - 3) Vectors of the form [x1 x2 ...] match vectors of the same length. - 4) Maps of the form {:key1 x1 :key2 x2 ...} match maps that have - the same keys as the template, but which can have additional keys - that are not part of the template. - The values x1, x2, ... can be symbols or non-symbol values. Non-symbols - must be equal to the corresponding values in the object to be matched. - Symbols will be bound to the corresponding value in the object in the - evaluation of expr. If the same symbol occurs more than once in a, - template the corresponding elements of the object must be equal - for the template to match." - [value & clauses] - (when (odd? (count clauses)) - (throw (Exception. "Odd number of elements in match expression"))) - (let [vsymbol (gensym) - cfsymbol (gensym) - terms (mapcat (fn [[template expr]] - (if (= template :else) - [template expr] - (let [[tests bindings] - (tests-and-bindings template vsymbol cfsymbol)] - [tests - (if (empty? bindings) - expr - `(let ~bindings ~expr))]))) - (partition 2 clauses))] - `(let [~vsymbol ~value - ~cfsymbol (constructor-form ~vsymbol)] - (cond ~@terms)))) diff --git a/src/clojure/contrib/types/examples.clj b/src/clojure/contrib/types/examples.clj deleted file mode 100644 index 486f8ce6..00000000 --- a/src/clojure/contrib/types/examples.clj +++ /dev/null @@ -1,152 +0,0 @@ -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; Application examples for data types -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(ns - #^{:author "Konrad Hinsen" - :skip-wiki true - :doc "Examples for data type definitions"} - clojure.contrib.types.examples - (:refer-clojure :exclude (deftype)) - (:use [clojure.contrib.types - :only (deftype defadt match)]) - (:require [clojure.contrib.generic.collection :as gc]) - (:require [clojure.contrib.generic.functor :as gf])) - -; -; Multisets implemented as maps to integers -; - -; The most basic type definition. A more elaborate version could add -; a constructor that verifies that its argument is a map with integer values. -(deftype ::multiset multiset - "Multiset (demo implementation)") - -; Some set operations generalized to multisets -; Note that the multiset constructor is nowhere called explicitly, as the -; map operations all preserve the metadata. -(defmethod gc/conj ::multiset - ([ms x] - (assoc ms x (inc (get ms x 0)))) - ([ms x & xs] - (reduce gc/conj (gc/conj ms x) xs))) - -(defmulti union (fn [& sets] (type (first sets)))) - -(defmethod union clojure.lang.IPersistentSet - [& sets] - (apply clojure.set/union sets)) - -; Note: a production-quality implementation should accept standard sets -; and perhaps other collections for its second argument. -(defmethod union ::multiset - ([ms] ms) - ([ms1 ms2] - (letfn [(add-item [ms [item n]] - (assoc ms item (+ n (get ms item 0))))] - (reduce add-item ms1 ms2))) - ([ms1 ms2 & mss] - (reduce union (union ms1 ms2) mss))) - -; Let's use it: -(gc/conj #{} :a :a :b :c) -(gc/conj (multiset {}) :a :a :b :c) - -(union #{:a :b} #{:b :c}) -(union (multiset {:a 1 :b 1}) (multiset {:b 1 :c 2})) - -; -; A simple tree structure defined as an algebraic data type -; -(defadt ::tree - empty-tree - (leaf value) - (node left-tree right-tree)) - -(def a-tree (node (leaf :a) - (node (leaf :b) - (leaf :c)))) - -(defn depth - [t] - (match t - empty-tree 0 - (leaf _) 1 - (node l r) (inc (max (depth l) (depth r))))) - -(depth empty-tree) -(depth (leaf 42)) -(depth a-tree) - -; Algebraic data types with multimethods: fmap on a tree -(defmethod gf/fmap ::tree - [f t] - (match t - empty-tree empty-tree - (leaf v) (leaf (f v)) - (node l r) (node (gf/fmap f l) (gf/fmap f r)))) - -(gf/fmap str a-tree) - -; -; Nonsense examples to illustrate all the features of match -; for type constructors. -; -(defadt ::foo - (bar a b c)) - -(defn foo-to-int - [a-foo] - (match a-foo - (bar x x x) x - (bar 0 x y) (+ x y) - (bar 1 2 3) -1 - (bar a b 1) (* a b) - :else 42)) - -(foo-to-int (bar 0 0 0)) ; 0 -(foo-to-int (bar 0 5 6)) ; 11 -(foo-to-int (bar 1 2 3)) ; -1 -(foo-to-int (bar 3 3 1)) ; 9 -(foo-to-int (bar 0 3 1)) ; 4 -(foo-to-int (bar 10 20 30)) ; 42 - -; -; Match can also be used for lists, vectors, and maps. Note that since -; algebraic data types are represented as maps, they can be matched -; either with their type constructor and positional arguments, or -; with a map template. -; - -; Tree depth once again with map templates -(defn depth - [t] - (match t - empty-tree 0 - {:value _} 1 - {:left-tree l :right-tree r} (inc (max (depth l) (depth r))))) - -(depth empty-tree) -(depth (leaf 42)) -(depth a-tree) - -; Match for lists, vectors, and maps: - -(for [x ['(1 2 3) - [1 2 3] - {:x 1 :y 2 :z 3} - '(1 1 1) - [2 1 2] - {:x 1 :y 1 :z 2}]] - (match x - '(a a a) 'list-of-three-equal-values - '(a b c) 'list - [a a a] 'vector-of-three-equal-values - [a b a] 'vector-of-three-with-first-and-last-equal - [a b c] 'vector - {:x a :y z} 'map-with-x-equal-y - {} 'any-map)) diff --git a/src/clojure/contrib/with_ns.clj b/src/clojure/contrib/with_ns.clj deleted file mode 100644 index d874a4a5..00000000 --- a/src/clojure/contrib/with_ns.clj +++ /dev/null @@ -1,38 +0,0 @@ -;;; with_ns.clj -- temporary namespace macro - -;; by Stuart Sierra, http://stuartsierra.com/ -;; March 28, 2009 - -;; Copyright (c) Stuart Sierra, 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. - - -(ns - #^{:author "Stuart Sierra", - :doc "Temporary namespace macro"} - clojure.contrib.with-ns) - -(defmacro with-ns - "Evaluates body in another namespace. ns is either a namespace - object or a symbol. This makes it possible to define functions in - namespaces other than the current one." - [ns & body] - `(binding [*ns* (the-ns ~ns)] - ~@(map (fn [form] `(eval '~form)) body))) - -(defmacro with-temp-ns - "Evaluates body in an anonymous namespace, which is then immediately - removed. The temporary namespace will 'refer' clojure.core." - [& body] - `(try - (create-ns 'sym#) - (let [result# (with-ns 'sym# - (clojure.core/refer-clojure) - ~@body)] - result#) - (finally (remove-ns 'sym#)))) diff --git a/src/clojure/contrib/zip_filter.clj b/src/clojure/contrib/zip_filter.clj deleted file mode 100644 index c7599bf8..00000000 --- a/src/clojure/contrib/zip_filter.clj +++ /dev/null @@ -1,92 +0,0 @@ -; Copyright (c) Chris Houser, April 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. - -; System for filtering trees and nodes generated by zip.clj in -; general, and xml trees in particular. - -(ns - #^{:author "Chris Houser", - :doc "System for filtering trees and nodes generated by zip.clj in -general, and xml trees in particular. -"} - clojure.contrib.zip-filter - (:refer-clojure :exclude (descendants ancestors)) - (:require [clojure.zip :as zip])) - -; This uses the negative form (no-auto) so that the result from any -; naive function, including user functions, defaults to "auto". -(defn auto - [v x] (with-meta x ((if v dissoc assoc) (meta x) :zip-filter/no-auto? true))) - -(defn auto? - [x] (not (:zip-filter/no-auto? (meta x)))) - -(defn right-locs - "Returns a lazy sequence of locations to the right of loc, starting with loc." - [loc] (lazy-seq (when loc (cons (auto false loc) (right-locs (zip/right loc)))))) - -(defn left-locs - "Returns a lazy sequence of locations to the left of loc, starting with loc." - [loc] (lazy-seq (when loc (cons (auto false loc) (left-locs (zip/left loc)))))) - -(defn leftmost? - "Returns true if there are no more nodes to the left of location loc." - [loc] (nil? (zip/left loc))) - -(defn rightmost? - "Returns true if there are no more nodes to the right of location loc." - [loc] (nil? (zip/right loc))) - -(defn children - "Returns a lazy sequence of all immediate children of location loc, - left-to-right." - [loc] - (when (zip/branch? loc) - (map #(auto false %) (right-locs (zip/down loc))))) - -(defn children-auto - "Returns a lazy sequence of all immediate children of location loc, - left-to-right, marked so that a following tag= predicate will auto-descend." - #^{:private true} - [loc] - (when (zip/branch? loc) - (map #(auto true %) (right-locs (zip/down loc))))) - -(defn descendants - "Returns a lazy sequence of all descendants of location loc, in - depth-first order, left-to-right, starting with loc." - [loc] (lazy-seq (cons (auto false loc) (mapcat descendants (children loc))))) - -(defn ancestors - "Returns a lazy sequence of all ancestors of location loc, starting - with loc and proceeding to loc's parent node and on through to the - root of the tree." - [loc] (lazy-seq (when loc (cons (auto false loc) (ancestors (zip/up loc)))))) - -(defn- fixup-apply - "Calls (pred loc), and then converts the result to the 'appropriate' - sequence." - #^{:private true} - [pred loc] - (let [rtn (pred loc)] - (cond (and (map? (meta rtn)) (:zip-filter/is-node? (meta rtn))) (list rtn) - (= rtn true) (list loc) - (= rtn false) nil - (nil? rtn) nil - (sequential? rtn) rtn - :else (list rtn)))) - -(defn mapcat-chain - #^{:private true} - [loc preds mkpred] - (reduce (fn [prevseq expr] - (mapcat #(fixup-apply (or (mkpred expr) expr) %) prevseq)) - (list (with-meta loc (assoc (meta loc) :zip-filter/is-node? true))) - preds)) - -; see clojure.contrib.zip-filter.xml for examples diff --git a/src/clojure/contrib/zip_filter/xml.clj b/src/clojure/contrib/zip_filter/xml.clj deleted file mode 100644 index e6e8cb3d..00000000 --- a/src/clojure/contrib/zip_filter/xml.clj +++ /dev/null @@ -1,170 +0,0 @@ -; Copyright (c) Chris Houser, April 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. - -; Specialization of zip-filter for xml trees. - -(ns clojure.contrib.zip-filter.xml - (:require [clojure.contrib.zip-filter :as zf] - [clojure.zip :as zip] - [clojure.xml :as xml])) - -(declare xml->) - -(defn attr - "Returns the xml attribute named attrname, of the xml node at location loc." - ([attrname] (fn [loc] (attr loc attrname))) - ([loc attrname] (when (zip/branch? loc) (-> loc zip/node :attrs attrname)))) - -(defn attr= - "Returns a query predicate that matches a node when it has an - attribute named attrname whose value is attrval." - [attrname attrval] (fn [loc] (= attrval (attr loc attrname)))) - -(defn tag= - "Returns a query predicate that matches a node when its is a tag - named tagname." - [tagname] - (fn [loc] - (filter #(and (zip/branch? %) (= tagname ((zip/node %) :tag))) - (if (zf/auto? loc) - (zf/children-auto loc) - (list (zf/auto true loc)))))) - -(defn text - "Returns the textual contents of the given location, similar to - xpaths's value-of" - [loc] - (.replaceAll - #^String (apply str (xml-> loc zf/descendants zip/node string?)) - (str "[\\s" (char 160) "]+") " ")) - -(defn text= - "Returns a query predicate that matches a node when its textual - content equals s." - [s] (fn [loc] (= (text loc) s))) - -(defn seq-test - "Returns a query predicate that matches a node when its xml content - matches the query expresions given." - #^{:private true} - [preds] (fn [loc] (and (seq (apply xml-> loc preds)) (list loc)))) - -(defn xml-> - "The loc is passed to the first predicate. If the predicate returns - a collection, each value of the collection is passed to the next - predicate. If it returns a location, the location is passed to the - next predicate. If it returns true, the input location is passed to - the next predicate. If it returns false or nil, the next predicate - is not called. - - This process is repeated, passing the processed results of each - predicate to the next predicate. xml-> returns the final sequence. - The entire chain is evaluated lazily. - - There are also special predicates: keywords are converted to tag=, - strings to text=, and vectors to sub-queries that return true if - they match. - - See the footer of zip-query.clj for examples." - [loc & preds] - (zf/mapcat-chain loc preds - #(cond (keyword? %) (tag= %) - (string? %) (text= %) - (vector? %) (seq-test %)))) - -(defn xml1-> - "Returns the first item from loc based on the query predicates - given. See xml->" - [loc & preds] (first (apply xml-> loc preds))) - - -; === examples === - -(comment - -(defn parse-str [s] - (zip/xml-zip (xml/parse (new org.xml.sax.InputSource - (new java.io.StringReader s))))) - -(def atom1 (parse-str "<?xml version='1.0' encoding='UTF-8'?> -<feed xmlns='http://www.w3.org/2005/Atom'> - <id>tag:blogger.com,1999:blog-28403206</id> - <updated>2008-02-14T08:00:58.567-08:00</updated> - <title type='text'>n01senet</title> - <link rel='alternate' type='text/html' href='http://n01senet.blogspot.com/'/> - <entry> - <id>1</id> - <published>2008-02-13</published> - <title type='text'>clojure is the best lisp yet</title> - <author><name>Chouser</name></author> - </entry> - <entry> - <id>2</id> - <published>2008-02-07</published> - <title type='text'>experimenting with vnc</title> - <author><name>agriffis</name></author> - </entry> -</feed> -")) - -; simple single-function filter -(assert (= (xml-> atom1 #((zip/node %) :tag)) - '(:feed))) - -; two-stage filter using helpful query prediates -(assert (= (xml-> atom1 (tag= :title) text) - '("n01senet"))) - -; same filter as above, this time using keyword shortcut -(assert (= (xml-> atom1 :title text) - '("n01senet"))) - -; multi-stage filter -(assert (= (xml-> atom1 :entry :author :name text) - '("Chouser" "agriffis"))) - -; test xml1-> -(assert (= (xml1-> atom1 :entry :author :name text) - "Chouser")) - -; multi-stage filter with subquery specified using a vector -(assert (= (xml-> atom1 :entry [:author :name (text= "agriffis")] - :id text) - '("2"))) - -; same filter as above, this time using a string shortcut -(assert (= (xml-> atom1 :entry [:author :name "agriffis"] :id text) - '("2"))) - -; attribute access -(assert (= (xml-> atom1 :title (attr :type)) - '("text"))) - -; attribute filtering -(assert (= (xml-> atom1 :link [(attr= :rel "alternate")] (attr :type)) - '("text/html"))) - -; ancestors -(assert (= (xml-> atom1 zf/descendants :id "2" zf/ancestors zip/node #(:tag %)) - '(:id :entry :feed))) - -; ancestors with non-auto tag= (:entry), followed by auto tag= (:id) -(assert (= (xml-> atom1 zf/descendants :name "Chouser" zf/ancestors - :entry :id text) - '("1"))) - -; left-locs and detection of returning a single loc (zip/up) -(assert (= (xml-> atom1 zf/descendants :name "Chouser" zip/up - zf/left-locs :id text) - '("1"))) - -; right-locs -(assert (= (xml-> atom1 zf/descendants :id zf/right-locs :author text) - '("Chouser" "agriffis"))) - -) |