Mercurial > lasercutter
comparison src/clojure/pprint/utilities.clj @ 10:ef7dbbd6452c
added clojure source goodness
author | Robert McIntyre <rlm@mit.edu> |
---|---|
date | Sat, 21 Aug 2010 06:25:44 -0400 |
parents | |
children |
comparison
equal
deleted
inserted
replaced
9:35cf337adfcf | 10:ef7dbbd6452c |
---|---|
1 ;;; utilities.clj -- part of the pretty printer for Clojure | |
2 | |
3 ; Copyright (c) Rich Hickey. All rights reserved. | |
4 ; The use and distribution terms for this software are covered by the | |
5 ; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) | |
6 ; which can be found in the file epl-v10.html at the root of this distribution. | |
7 ; By using this software in any fashion, you are agreeing to be bound by | |
8 ; the terms of this license. | |
9 ; You must not remove this notice, or any other, from this software. | |
10 | |
11 ;; Author: Tom Faulhaber | |
12 ;; April 3, 2009 | |
13 | |
14 ;; This module implements some utility function used in formatting and pretty | |
15 ;; printing. The functions here could go in a more general purpose library, | |
16 ;; perhaps. | |
17 | |
18 (in-ns 'clojure.pprint) | |
19 | |
20 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
21 ;;; Helper functions for digesting formats in the various | |
22 ;;; phases of their lives. | |
23 ;;; These functions are actually pretty general. | |
24 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
25 | |
26 (defn- map-passing-context [func initial-context lis] | |
27 (loop [context initial-context | |
28 lis lis | |
29 acc []] | |
30 (if (empty? lis) | |
31 [acc context] | |
32 (let [this (first lis) | |
33 remainder (next lis) | |
34 [result new-context] (apply func [this context])] | |
35 (recur new-context remainder (conj acc result)))))) | |
36 | |
37 (defn- consume [func initial-context] | |
38 (loop [context initial-context | |
39 acc []] | |
40 (let [[result new-context] (apply func [context])] | |
41 (if (not result) | |
42 [acc new-context] | |
43 (recur new-context (conj acc result)))))) | |
44 | |
45 (defn- consume-while [func initial-context] | |
46 (loop [context initial-context | |
47 acc []] | |
48 (let [[result continue new-context] (apply func [context])] | |
49 (if (not continue) | |
50 [acc context] | |
51 (recur new-context (conj acc result)))))) | |
52 | |
53 (defn- unzip-map [m] | |
54 "Take a map that has pairs in the value slots and produce a pair of maps, | |
55 the first having all the first elements of the pairs and the second all | |
56 the second elements of the pairs" | |
57 [(into {} (for [[k [v1 v2]] m] [k v1])) | |
58 (into {} (for [[k [v1 v2]] m] [k v2]))]) | |
59 | |
60 (defn- tuple-map [m v1] | |
61 "For all the values, v, in the map, replace them with [v v1]" | |
62 (into {} (for [[k v] m] [k [v v1]]))) | |
63 | |
64 (defn- rtrim [s c] | |
65 "Trim all instances of c from the end of sequence s" | |
66 (let [len (count s)] | |
67 (if (and (pos? len) (= (nth s (dec (count s))) c)) | |
68 (loop [n (dec len)] | |
69 (cond | |
70 (neg? n) "" | |
71 (not (= (nth s n) c)) (subs s 0 (inc n)) | |
72 true (recur (dec n)))) | |
73 s))) | |
74 | |
75 (defn- ltrim [s c] | |
76 "Trim all instances of c from the beginning of sequence s" | |
77 (let [len (count s)] | |
78 (if (and (pos? len) (= (nth s 0) c)) | |
79 (loop [n 0] | |
80 (if (or (= n len) (not (= (nth s n) c))) | |
81 (subs s n) | |
82 (recur (inc n)))) | |
83 s))) | |
84 | |
85 (defn- prefix-count [aseq val] | |
86 "Return the number of times that val occurs at the start of sequence aseq, | |
87 if val is a seq itself, count the number of times any element of val occurs at the | |
88 beginning of aseq" | |
89 (let [test (if (coll? val) (set val) #{val})] | |
90 (loop [pos 0] | |
91 (if (or (= pos (count aseq)) (not (test (nth aseq pos)))) | |
92 pos | |
93 (recur (inc pos)))))) | |
94 | |
95 (defn- prerr [& args] | |
96 "Println to *err*" | |
97 (binding [*out* *err*] | |
98 (apply println args))) | |
99 | |
100 (defmacro ^{:private true} prlabel [prefix arg & more-args] | |
101 "Print args to *err* in name = value format" | |
102 `(prerr ~@(cons (list 'quote prefix) (mapcat #(list (list 'quote %) "=" %) | |
103 (cons arg (seq more-args)))))) | |
104 |