1.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
     1.2 +++ b/src/clojure/pprint/utilities.clj	Sat Aug 21 06:25:44 2010 -0400
     1.3 @@ -0,0 +1,104 @@
     1.4 +;;; utilities.clj -- part of the pretty printer for Clojure
     1.5 +
     1.6 +;   Copyright (c) Rich Hickey. All rights reserved.
     1.7 +;   The use and distribution terms for this software are covered by the
     1.8 +;   Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)
     1.9 +;   which can be found in the file epl-v10.html at the root of this distribution.
    1.10 +;   By using this software in any fashion, you are agreeing to be bound by
    1.11 +;   the terms of this license.
    1.12 +;   You must not remove this notice, or any other, from this software.
    1.13 +
    1.14 +;; Author: Tom Faulhaber
    1.15 +;; April 3, 2009
    1.16 +
    1.17 +;; This module implements some utility function used in formatting and pretty
    1.18 +;; printing. The functions here could go in a more general purpose library,
    1.19 +;; perhaps.
    1.20 +
    1.21 +(in-ns 'clojure.pprint)
    1.22 +
    1.23 +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    1.24 +;;; Helper functions for digesting formats in the various
    1.25 +;;; phases of their lives.
    1.26 +;;; These functions are actually pretty general.
    1.27 +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    1.28 +
    1.29 +(defn- map-passing-context [func initial-context lis]
    1.30 +  (loop [context initial-context
    1.31 +         lis lis
    1.32 +         acc []]
    1.33 +    (if (empty? lis)
    1.34 +      [acc context]
    1.35 +    (let [this (first lis)
    1.36 +          remainder (next lis)
    1.37 +          [result new-context] (apply func [this context])]
    1.38 +      (recur new-context remainder (conj acc result))))))
    1.39 +
    1.40 +(defn- consume [func initial-context]
    1.41 +  (loop [context initial-context
    1.42 +         acc []]
    1.43 +    (let [[result new-context] (apply func [context])]
    1.44 +      (if (not result)
    1.45 +        [acc new-context]
    1.46 +      (recur new-context (conj acc result))))))
    1.47 +
    1.48 +(defn- consume-while [func initial-context]
    1.49 +  (loop [context initial-context
    1.50 +         acc []]
    1.51 +    (let [[result continue new-context] (apply func [context])]
    1.52 +      (if (not continue)
    1.53 +        [acc context]
    1.54 +      (recur new-context (conj acc result))))))
    1.55 +
    1.56 +(defn- unzip-map [m]
    1.57 +  "Take a  map that has pairs in the value slots and produce a pair of maps, 
    1.58 +   the first having all the first elements of the pairs and the second all 
    1.59 +   the second elements of the pairs"
    1.60 +  [(into {} (for [[k [v1 v2]] m] [k v1]))
    1.61 +   (into {} (for [[k [v1 v2]] m] [k v2]))])
    1.62 +
    1.63 +(defn- tuple-map [m v1]
    1.64 +  "For all the values, v, in the map, replace them with [v v1]"
    1.65 +  (into {} (for [[k v] m] [k [v v1]])))
    1.66 +
    1.67 +(defn- rtrim [s c]
    1.68 +  "Trim all instances of c from the end of sequence s"
    1.69 +  (let [len (count s)]
    1.70 +    (if (and (pos? len) (= (nth s (dec (count s))) c))
    1.71 +      (loop [n (dec len)]
    1.72 +        (cond 
    1.73 +         (neg? n) ""
    1.74 +         (not (= (nth s n) c)) (subs s 0 (inc n))
    1.75 +         true (recur (dec n))))
    1.76 +      s)))
    1.77 +
    1.78 +(defn- ltrim [s c]
    1.79 +  "Trim all instances of c from the beginning of sequence s"
    1.80 +  (let [len (count s)]
    1.81 +    (if (and (pos? len) (= (nth s 0) c))
    1.82 +      (loop [n 0]
    1.83 +        (if (or (= n len) (not (= (nth s n) c)))
    1.84 +          (subs s n)
    1.85 +          (recur (inc n))))
    1.86 +      s)))
    1.87 +
    1.88 +(defn- prefix-count [aseq val]
    1.89 +  "Return the number of times that val occurs at the start of sequence aseq, 
    1.90 +if val is a seq itself, count the number of times any element of val occurs at the
    1.91 +beginning of aseq"
    1.92 +  (let [test (if (coll? val) (set val) #{val})]
    1.93 +    (loop [pos 0]
    1.94 +     (if (or (= pos (count aseq)) (not (test (nth aseq pos))))
    1.95 +       pos
    1.96 +       (recur (inc pos))))))
    1.97 +
    1.98 +(defn- prerr [& args]
    1.99 +  "Println to *err*"
   1.100 +  (binding [*out* *err*]
   1.101 +    (apply println args)))
   1.102 +       
   1.103 +(defmacro ^{:private true} prlabel [prefix arg & more-args]
   1.104 +  "Print args to *err* in name = value format"
   1.105 +  `(prerr ~@(cons (list 'quote prefix) (mapcat #(list (list 'quote %) "=" %) 
   1.106 +                                                  (cons arg (seq more-args))))))
   1.107 +