Mercurial > lasercutter

     1 ;;; cl_format.clj -- part of the pretty printer for Clojure

     2 

     3 ;; by Tom Faulhaber

     4 ;; April 3, 2009

     5 

     6 ;   Copyright (c) Tom Faulhaber, Dec 2008. All rights reserved.

     7 ;   The use and distribution terms for this software are covered by the

     8 ;   Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)

     9 ;   which can be found in the file epl-v10.html at the root of this distribution.

    10 ;   By using this software in any fashion, you are agreeing to be bound by

    11 ;   the terms of this license.

    12 ;   You must not remove this notice, or any other, from this software.

    13 

    14 ;; This module implements the Common Lisp compatible format function as documented

    15 ;; in "Common Lisp the Language, 2nd edition", Chapter 22 (available online at:

    16 ;; http://www.cs.cmu.edu/afs/cs.cmu.edu/project/ai-repository/ai/html/cltl/clm/node200.html#SECTION002633000000000000000)

    17 

    18 (in-ns 'clojure.contrib.pprint)

    19 

    20 ;;; Forward references

    21 (declare compile-format)

    22 (declare execute-format)

    23 (declare init-navigator)

    24 ;;; End forward references

    25 

    26 (defn cl-format 

    27   "An implementation of a Common Lisp compatible format function. cl-format formats its

    28 arguments to an output stream or string based on the format control string given. It 

    29 supports sophisticated formatting of structured data.

    30 

    31 Writer is an instance of java.io.Writer, true to output to *out* or nil to output 

    32 to a string, format-in is the format control string and the remaining arguments 

    33 are the data to be formatted.

    34 

    35 The format control string is a string to be output with embedded 'format directives' 

    36 describing how to format the various arguments passed in.

    37 

    38 If writer is nil, cl-format returns the formatted result string. Otherwise, cl-format 

    39 returns nil.

    40 

    41 For example:

    42  (let [results [46 38 22]]

    43         (cl-format true \"There ~[are~;is~:;are~]~:* ~d result~:p: ~{~d~^, ~}~%\" 

    44                    (count results) results))

    45 

    46 Prints to *out*:

    47  There are 3 results: 46, 38, 22

    48 

    49 Detailed documentation on format control strings is available in the \"Common Lisp the 

    50 Language, 2nd edition\", Chapter 22 (available online at:

    51 http://www.cs.cmu.edu/afs/cs.cmu.edu/project/ai-repository/ai/html/cltl/clm/node200.html#SECTION002633000000000000000) 

    52 and in the Common Lisp HyperSpec at 

    53 http://www.lispworks.com/documentation/HyperSpec/Body/22_c.htm

    54 "

    55   {:see-also [["http://www.cs.cmu.edu/afs/cs.cmu.edu/project/ai-repository/ai/html/cltl/clm/node200.html#SECTION002633000000000000000" 

    56                "Common Lisp the Language"]

    57               ["http://www.lispworks.com/documentation/HyperSpec/Body/22_c.htm"

    58                "Common Lisp HyperSpec"]]}

    59   [writer format-in & args]

    60   (let [compiled-format (if (string? format-in) (compile-format format-in) format-in)

    61         navigator (init-navigator args)]

    62     (execute-format writer compiled-format navigator)))

    63 

    64 (def ^{:private true} *format-str* nil)

    65 

    66 (defn- format-error [message offset] 

    67   (let [full-message (str message \newline *format-str* \newline 

    68                            (apply str (repeat offset \space)) "^" \newline)]

    69     (throw (RuntimeException. full-message))))

    70 

    71 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

    72 ;;; Argument navigators manage the argument list

    73 ;;; as the format statement moves through the list

    74 ;;; (possibly going forwards and backwards as it does so)

    75 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

    76 

    77 (defstruct ^{:private true}

    78   arg-navigator :seq :rest :pos )

    79 

    80 (defn init-navigator 

    81   "Create a new arg-navigator from the sequence with the position set to 0"

    82   {:skip-wiki true}

    83   [s]

    84   (let [s (seq s)]

    85     (struct arg-navigator s s 0)))

    86 

    87 ;; TODO call format-error with offset

    88 (defn- next-arg [ navigator ]

    89   (let [ rst (:rest navigator) ]

    90     (if rst

    91       [(first rst) (struct arg-navigator (:seq navigator ) (next rst) (inc (:pos navigator)))]

    92      (throw (new Exception  "Not enough arguments for format definition")))))

    93 

    94 (defn- next-arg-or-nil [navigator]

    95   (let [rst (:rest navigator)]

    96     (if rst

    97       [(first rst) (struct arg-navigator (:seq navigator ) (next rst) (inc (:pos navigator)))]

    98       [nil navigator])))

    99 

   100 ;; Get an argument off the arg list and compile it if it's not already compiled

   101 (defn- get-format-arg [navigator]

   102   (let [[raw-format navigator] (next-arg navigator)

   103         compiled-format (if (instance? String raw-format) 

   104                                (compile-format raw-format)

   105                                raw-format)]

   106     [compiled-format navigator]))

   107 

   108 (declare relative-reposition)

   109 

   110 (defn- absolute-reposition [navigator position]

   111   (if (>= position (:pos navigator))

   112     (relative-reposition navigator (- (:pos navigator) position))

   113     (struct arg-navigator (:seq navigator) (drop position (:seq navigator)) position)))

   114 

   115 (defn- relative-reposition [navigator position]

   116   (let [newpos (+ (:pos navigator) position)]

   117     (if (neg? position)

   118       (absolute-reposition navigator newpos)

   119       (struct arg-navigator (:seq navigator) (drop position (:rest navigator)) newpos))))

   120 

   121 (defstruct ^{:private true}

   122   compiled-directive :func :def :params :offset)

   123 

   124 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

   125 ;;; When looking at the parameter list, we may need to manipulate

   126 ;;; the argument list as well (for 'V' and '#' parameter types).

   127 ;;; We hide all of this behind a function, but clients need to

   128 ;;; manage changing arg navigator

   129 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

   130 

   131 ;; TODO: validate parameters when they come from arg list

   132 (defn- realize-parameter [[param [raw-val offset]] navigator]

   133   (let [[real-param new-navigator]

   134         (cond 

   135          (contains? #{ :at :colon } param) ;pass flags through unchanged - this really isn't necessary

   136          [raw-val navigator]

   137 

   138          (= raw-val :parameter-from-args) 

   139          (next-arg navigator)

   140 

   141          (= raw-val :remaining-arg-count) 

   142          [(count (:rest navigator)) navigator]

   143 

   144          true 

   145          [raw-val navigator])]

   146     [[param [real-param offset]] new-navigator]))

   147          

   148 (defn- realize-parameter-list [parameter-map navigator]

   149   (let [[pairs new-navigator] 

   150         (map-passing-context realize-parameter navigator parameter-map)]

   151     [(into {} pairs) new-navigator]))

   152 

   153 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

   154 ;;; Functions that support individual directives

   155 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

   156 

   157 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

   158 ;;; Common handling code for ~A and ~S

   159 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

   160 

   161 (declare opt-base-str)

   162 

   163 (def ^{:private true}

   164      special-radix-markers {2 "#b" 8 "#o", 16 "#x"})

   165 

   166 (defn- format-simple-number [n]

   167   (cond 

   168     (integer? n) (if (= *print-base* 10)

   169                    (str n (if *print-radix* "."))

   170                    (str

   171                     (if *print-radix* (or (get special-radix-markers *print-base*) (str "#" *print-base* "r")))

   172                     (opt-base-str *print-base* n)))

   173     (ratio? n) (str

   174                 (if *print-radix* (or (get special-radix-markers *print-base*) (str "#" *print-base* "r")))

   175                 (opt-base-str *print-base* (.numerator n))

   176                 "/"

   177                 (opt-base-str *print-base* (.denominator n)))

   178     :else nil))

   179 

   180 (defn- format-ascii [print-func params arg-navigator offsets]

   181   (let [ [arg arg-navigator] (next-arg arg-navigator) 

   182          ^String base-output (or (format-simple-number arg) (print-func arg))

   183          base-width (.length base-output)

   184          min-width (+ base-width (:minpad params))

   185          width (if (>= min-width (:mincol params)) 

   186                  min-width

   187                  (+ min-width 

   188                     (* (+ (quot (- (:mincol params) min-width 1) 

   189                                 (:colinc params) )

   190                           1)

   191                        (:colinc params))))

   192          chars (apply str (repeat (- width base-width) (:padchar params)))]

   193     (if (:at params)

   194       (print (str chars base-output))

   195       (print (str base-output chars)))

   196     arg-navigator))

   197 

   198 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

   199 ;;; Support for the integer directives ~D, ~X, ~O, ~B and some

   200 ;;; of ~R

   201 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

   202 

   203 (defn- integral?

   204   "returns true if a number is actually an integer (that is, has no fractional part)"

   205   [x]

   206   (cond

   207    (integer? x) true

   208    (decimal? x) (>= (.ulp (.stripTrailingZeros (bigdec 0))) 1) ; true iff no fractional part

   209    (float? x)   (= x (Math/floor x))

   210    (ratio? x)   (let [^clojure.lang.Ratio r x]

   211                   (= 0 (rem (.numerator r) (.denominator r))))

   212    :else        false))

   213 

   214 (defn- remainders

   215   "Return the list of remainders (essentially the 'digits') of val in the given base"

   216   [base val]

   217   (reverse 

   218    (first 

   219     (consume #(if (pos? %) 

   220                 [(rem % base) (quot % base)] 

   221                 [nil nil]) 

   222              val))))

   223 

   224 ;;; TODO: xlated-val does not seem to be used here.

   225 (defn- base-str

   226   "Return val as a string in the given base"

   227   [base val]

   228   (if (zero? val)

   229     "0"

   230     (let [xlated-val (cond

   231                        (float? val) (bigdec val)

   232                        (ratio? val) (let [^clojure.lang.Ratio r val] 

   233                                       (/ (.numerator r) (.denominator r)))

   234                        :else val)] 

   235       (apply str 

   236              (map 

   237               #(if (< % 10) (char (+ (int \0) %)) (char (+ (int \a) (- % 10)))) 

   238               (remainders base val))))))

   239 

   240 (def ^{:private true}

   241      java-base-formats {8 "%o", 10 "%d", 16 "%x"})

   242 

   243 (defn- opt-base-str

   244   "Return val as a string in the given base, using clojure.core/format if supported

   245 for improved performance"

   246   [base val]

   247   (let [format-str (get java-base-formats base)]

   248     (if (and format-str (integer? val) (-> val class .getName (.startsWith "java.")))

   249       (clojure.core/format format-str val)

   250       (base-str base val))))

   251 

   252 (defn- group-by* [unit lis]

   253   (reverse

   254    (first

   255     (consume (fn [x] [(seq (reverse (take unit x))) (seq (drop unit x))]) (reverse lis)))))

   256 

   257 (defn- format-integer [base params arg-navigator offsets]

   258   (let [[arg arg-navigator] (next-arg arg-navigator)]

   259     (if (integral? arg)

   260       (let [neg (neg? arg)

   261             pos-arg (if neg (- arg) arg)

   262             raw-str (opt-base-str base pos-arg)

   263             group-str (if (:colon params)

   264                         (let [groups (map #(apply str %) (group-by* (:commainterval params) raw-str))

   265                               commas (repeat (count groups) (:commachar params))]

   266                           (apply str (next (interleave commas groups))))

   267                         raw-str)

   268             ^String signed-str (cond

   269                                   neg (str "-" group-str)

   270                                   (:at params) (str "+" group-str)

   271                                   true group-str)

   272             padded-str (if (< (.length signed-str) (:mincol params))

   273                          (str (apply str (repeat (- (:mincol params) (.length signed-str)) 

   274                                                  (:padchar params)))

   275                               signed-str)

   276                          signed-str)]

   277         (print padded-str))

   278       (format-ascii print-str {:mincol (:mincol params) :colinc 1 :minpad 0 

   279                                :padchar (:padchar params) :at true} 

   280                     (init-navigator [arg]) nil))

   281     arg-navigator))

   282 

   283 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

   284 ;;; Support for english formats (~R and ~:R)

   285 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

   286 

   287 (def ^{:private true}

   288      english-cardinal-units 

   289      ["zero" "one" "two" "three" "four" "five" "six" "seven" "eight" "nine"

   290       "ten" "eleven" "twelve" "thirteen" "fourteen"

   291       "fifteen" "sixteen" "seventeen" "eighteen" "nineteen"])

   292 

   293 (def ^{:private true}

   294      english-ordinal-units 

   295      ["zeroth" "first" "second" "third" "fourth" "fifth" "sixth" "seventh" "eighth" "ninth"

   296       "tenth" "eleventh" "twelfth" "thirteenth" "fourteenth"

   297       "fifteenth" "sixteenth" "seventeenth" "eighteenth" "nineteenth"])

   298 

   299 (def ^{:private true}

   300      english-cardinal-tens

   301      ["" "" "twenty" "thirty" "forty" "fifty" "sixty" "seventy" "eighty" "ninety"])

   302 

   303 (def ^{:private true}

   304      english-ordinal-tens

   305      ["" "" "twentieth" "thirtieth" "fortieth" "fiftieth"

   306       "sixtieth" "seventieth" "eightieth" "ninetieth"])

   307 

   308 ;; We use "short scale" for our units (see http://en.wikipedia.org/wiki/Long_and_short_scales)

   309 ;; Number names from http://www.jimloy.com/math/billion.htm

   310 ;; We follow the rules for writing numbers from the Blue Book

   311 ;; (http://www.grammarbook.com/numbers/numbers.asp)

   312 (def ^{:private true}

   313      english-scale-numbers 

   314      ["" "thousand" "million" "billion" "trillion" "quadrillion" "quintillion" 

   315       "sextillion" "septillion" "octillion" "nonillion" "decillion" 

   316       "undecillion" "duodecillion" "tredecillion" "quattuordecillion" 

   317       "quindecillion" "sexdecillion" "septendecillion" 

   318       "octodecillion" "novemdecillion" "vigintillion"])

   319 

   320 (defn- format-simple-cardinal

   321   "Convert a number less than 1000 to a cardinal english string"

   322   [num]

   323   (let [hundreds (quot num 100)

   324         tens (rem num 100)]

   325     (str

   326      (if (pos? hundreds) (str (nth english-cardinal-units hundreds) " hundred"))

   327      (if (and (pos? hundreds) (pos? tens)) " ")

   328      (if (pos? tens) 

   329        (if (< tens 20) 

   330          (nth english-cardinal-units tens)

   331          (let [ten-digit (quot tens 10)

   332                unit-digit (rem tens 10)]

   333            (str

   334             (if (pos? ten-digit) (nth english-cardinal-tens ten-digit))

   335             (if (and (pos? ten-digit) (pos? unit-digit)) "-")

   336             (if (pos? unit-digit) (nth english-cardinal-units unit-digit)))))))))

   337 

   338 (defn- add-english-scales

   339   "Take a sequence of parts, add scale numbers (e.g., million) and combine into a string

   340 offset is a factor of 10^3 to multiply by"

   341   [parts offset]

   342   (let [cnt (count parts)]

   343     (loop [acc []

   344            pos (dec cnt)

   345            this (first parts)

   346            remainder (next parts)]

   347       (if (nil? remainder)

   348         (str (apply str (interpose ", " acc))

   349              (if (and (not (empty? this)) (not (empty? acc))) ", ")

   350              this

   351              (if (and (not (empty? this)) (pos? (+ pos offset)))

   352                (str " " (nth english-scale-numbers (+ pos offset)))))

   353         (recur 

   354          (if (empty? this)

   355            acc

   356            (conj acc (str this " " (nth english-scale-numbers (+ pos offset)))))

   357          (dec pos)

   358          (first remainder)

   359          (next remainder))))))

   360 

   361 (defn- format-cardinal-english [params navigator offsets]

   362   (let [[arg navigator] (next-arg navigator)]

   363     (if (= 0 arg)

   364       (print "zero")

   365       (let [abs-arg (if (neg? arg) (- arg) arg) ; some numbers are too big for Math/abs

   366             parts (remainders 1000 abs-arg)]

   367         (if (<= (count parts) (count english-scale-numbers))

   368           (let [parts-strs (map format-simple-cardinal parts)

   369                 full-str (add-english-scales parts-strs 0)]

   370             (print (str (if (neg? arg) "minus ") full-str)))

   371           (format-integer ;; for numbers > 10^63, we fall back on ~D

   372            10

   373            { :mincol 0, :padchar \space, :commachar \, :commainterval 3, :colon true}

   374            (init-navigator [arg])

   375            { :mincol 0, :padchar 0, :commachar 0 :commainterval 0}))))

   376     navigator))

   377 

   378 (defn- format-simple-ordinal

   379   "Convert a number less than 1000 to a ordinal english string

   380 Note this should only be used for the last one in the sequence"

   381   [num]

   382   (let [hundreds (quot num 100)

   383         tens (rem num 100)]

   384     (str

   385      (if (pos? hundreds) (str (nth english-cardinal-units hundreds) " hundred"))

   386      (if (and (pos? hundreds) (pos? tens)) " ")

   387      (if (pos? tens) 

   388        (if (< tens 20) 

   389          (nth english-ordinal-units tens)

   390          (let [ten-digit (quot tens 10)

   391                unit-digit (rem tens 10)]

   392            (if (and (pos? ten-digit) (not (pos? unit-digit)))

   393              (nth english-ordinal-tens ten-digit)

   394              (str

   395               (if (pos? ten-digit) (nth english-cardinal-tens ten-digit))

   396               (if (and (pos? ten-digit) (pos? unit-digit)) "-")

   397               (if (pos? unit-digit) (nth english-ordinal-units unit-digit))))))

   398        (if (pos? hundreds) "th")))))

   399 

   400 (defn- format-ordinal-english [params navigator offsets]

   401   (let [[arg navigator] (next-arg navigator)]

   402     (if (= 0 arg)

   403       (print "zeroth")

   404       (let [abs-arg (if (neg? arg) (- arg) arg) ; some numbers are too big for Math/abs

   405             parts (remainders 1000 abs-arg)]

   406         (if (<= (count parts) (count english-scale-numbers))

   407           (let [parts-strs (map format-simple-cardinal (drop-last parts))

   408                 head-str (add-english-scales parts-strs 1)

   409                 tail-str (format-simple-ordinal (last parts))]

   410             (print (str (if (neg? arg) "minus ") 

   411                         (cond 

   412                          (and (not (empty? head-str)) (not (empty? tail-str))) 

   413                          (str head-str ", " tail-str)

   414                          

   415                          (not (empty? head-str)) (str head-str "th")

   416                          :else tail-str))))

   417           (do (format-integer ;; for numbers > 10^63, we fall back on ~D

   418                10

   419                { :mincol 0, :padchar \space, :commachar \, :commainterval 3, :colon true}

   420                (init-navigator [arg])

   421                { :mincol 0, :padchar 0, :commachar 0 :commainterval 0})

   422               (let [low-two-digits (rem arg 100)

   423                     not-teens (or (< 11 low-two-digits) (> 19 low-two-digits))

   424                     low-digit (rem low-two-digits 10)]

   425                 (print (cond 

   426                         (and (== low-digit 1) not-teens) "st"

   427                         (and (== low-digit 2) not-teens) "nd"

   428                         (and (== low-digit 3) not-teens) "rd"

   429                         :else "th")))))))

   430     navigator))

   431 

   432 

   433 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

   434 ;;; Support for roman numeral formats (~@R and ~@:R)

   435 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

   436 

   437 (def ^{:private true}

   438      old-roman-table

   439      [[ "I" "II" "III" "IIII" "V" "VI" "VII" "VIII" "VIIII"]

   440       [ "X" "XX" "XXX" "XXXX" "L" "LX" "LXX" "LXXX" "LXXXX"]

   441       [ "C" "CC" "CCC" "CCCC" "D" "DC" "DCC" "DCCC" "DCCCC"]

   442       [ "M" "MM" "MMM"]])

   443 

   444 (def ^{:private true}

   445      new-roman-table

   446      [[ "I" "II" "III" "IV" "V" "VI" "VII" "VIII" "IX"]

   447       [ "X" "XX" "XXX" "XL" "L" "LX" "LXX" "LXXX" "XC"]

   448       [ "C" "CC" "CCC" "CD" "D" "DC" "DCC" "DCCC" "CM"]

   449       [ "M" "MM" "MMM"]])

   450 

   451 (defn- format-roman

   452   "Format a roman numeral using the specified look-up table"

   453   [table params navigator offsets]

   454   (let [[arg navigator] (next-arg navigator)]

   455     (if (and (number? arg) (> arg 0) (< arg 4000))

   456       (let [digits (remainders 10 arg)]

   457         (loop [acc []

   458                pos (dec (count digits))

   459                digits digits]

   460           (if (empty? digits)

   461             (print (apply str acc))

   462             (let [digit (first digits)]

   463               (recur (if (= 0 digit) 

   464                        acc 

   465                        (conj acc (nth (nth table pos) (dec digit))))

   466                      (dec pos)

   467                      (next digits))))))

   468       (format-integer ;; for anything <= 0 or > 3999, we fall back on ~D

   469            10

   470            { :mincol 0, :padchar \space, :commachar \, :commainterval 3, :colon true}

   471            (init-navigator [arg])

   472            { :mincol 0, :padchar 0, :commachar 0 :commainterval 0}))

   473     navigator))

   474 

   475 (defn- format-old-roman [params navigator offsets]

   476   (format-roman old-roman-table params navigator offsets))

   477 

   478 (defn- format-new-roman [params navigator offsets]

   479   (format-roman new-roman-table params navigator offsets))

   480 

   481 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

   482 ;;; Support for character formats (~C)

   483 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

   484 

   485 (def ^{:private true} 

   486      special-chars { 8 "Backspace", 9 "Tab",  10 "Newline", 13 "Return", 32 "Space"})

   487 

   488 (defn- pretty-character [params navigator offsets]

   489   (let [[c navigator] (next-arg navigator)

   490         as-int (int c)

   491         base-char (bit-and as-int 127)

   492         meta (bit-and as-int 128)

   493         special (get special-chars base-char)]

   494     (if (> meta 0) (print "Meta-"))

   495     (print (cond

   496             special special

   497             (< base-char 32) (str "Control-" (char (+ base-char 64)))

   498             (= base-char 127) "Control-?"

   499             :else (char base-char)))

   500     navigator))

   501 

   502 (defn- readable-character [params navigator offsets]

   503   (let [[c navigator] (next-arg navigator)]

   504     (condp = (:char-format params)

   505       \o (cl-format true "\\o~3,'0o" (int c))

   506       \u (cl-format true "\\u~4,'0x" (int c))

   507       nil (pr c))

   508     navigator))

   509 

   510 (defn- plain-character [params navigator offsets]

   511   (let [[char navigator] (next-arg navigator)]

   512     (print char)

   513     navigator))

   514 

   515 ;; Check to see if a result is an abort (~^) construct

   516 ;; TODO: move these funcs somewhere more appropriate

   517 (defn- abort? [context]

   518   (let [token (first context)]

   519     (or (= :up-arrow token) (= :colon-up-arrow token))))

   520 

   521 ;; Handle the execution of "sub-clauses" in bracket constructions

   522 (defn- execute-sub-format [format args base-args]

   523   (second

   524    (map-passing-context 

   525     (fn [element context]

   526       (if (abort? context)

   527         [nil context] ; just keep passing it along

   528         (let [[params args] (realize-parameter-list (:params element) context)

   529               [params offsets] (unzip-map params)

   530               params (assoc params :base-args base-args)]

   531           [nil (apply (:func element) [params args offsets])])))

   532     args

   533     format)))

   534 

   535 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

   536 ;;; Support for real number formats

   537 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

   538 

   539 ;; TODO - return exponent as int to eliminate double conversion

   540 (defn- float-parts-base

   541   "Produce string parts for the mantissa (normalized 1-9) and exponent"

   542   [^Object f]

   543   (let [^String s (.toLowerCase (.toString f))

   544         exploc (.indexOf s (int \e))]

   545     (if (neg? exploc)

   546       (let [dotloc (.indexOf s (int \.))]

   547         (if (neg? dotloc)

   548           [s (str (dec (count s)))]

   549           [(str (subs s 0 dotloc) (subs s (inc dotloc))) (str (dec dotloc))]))

   550       [(str (subs s 0 1) (subs s 2 exploc)) (subs s (inc exploc))])))

   551 

   552 

   553 (defn- float-parts

   554   "Take care of leading and trailing zeros in decomposed floats"

   555   [f]

   556   (let [[m ^String e] (float-parts-base f)

   557         m1 (rtrim m \0)

   558         m2 (ltrim m1 \0)

   559         delta (- (count m1) (count m2))

   560         ^String e (if (and (pos? (count e)) (= (nth e 0) \+)) (subs e 1) e)]

   561     (if (empty? m2)

   562       ["0" 0]

   563       [m2 (- (Integer/valueOf e) delta)])))

   564 

   565 (defn- round-str [m e d w]

   566   (if (or d w)

   567     (let [len (count m)

   568           round-pos (if d (+ e d 1))

   569           round-pos (if (and w (< (inc e) (dec w)) 

   570                              (or (nil? round-pos) (< (dec w) round-pos)))

   571                       (dec w)

   572                       round-pos)

   573           [m1 e1 round-pos len] (if (= round-pos 0) 

   574                                   [(str "0" m) (inc e) 1 (inc len)]

   575                                   [m e round-pos len])]

   576       (if round-pos

   577         (if (neg? round-pos)

   578           ["0" 0 false]

   579           (if (> len round-pos)

   580             (let [round-char (nth m1 round-pos)

   581                   ^String result (subs m1 0 round-pos)]

   582               (if (>= (int round-char) (int \5))

   583                 (let [result-val (Integer/valueOf result)

   584                       leading-zeros (subs result 0 (min (prefix-count result \0) (- round-pos 1)))

   585                       round-up-result (str leading-zeros

   586                                            (String/valueOf (+ result-val 

   587                                                               (if (neg? result-val) -1 1))))

   588                       expanded (> (count round-up-result) (count result))]

   589                   [round-up-result e1 expanded])

   590                 [result e1 false]))

   591             [m e false]))

   592         [m e false]))

   593     [m e false]))

   594 

   595 (defn- expand-fixed [m e d]

   596   (let [m1 (if (neg? e) (str (apply str (repeat (dec (- e)) \0)) m) m)

   597         len (count m1)

   598         target-len (if d (+ e d 1) (inc e))]

   599     (if (< len target-len) 

   600       (str m1 (apply str (repeat (- target-len len) \0))) 

   601       m1)))

   602 

   603 (defn- insert-decimal

   604   "Insert the decimal point at the right spot in the number to match an exponent"

   605   [m e]

   606   (if (neg? e)

   607     (str "." m)

   608     (let [loc (inc e)]

   609       (str (subs m 0 loc) "." (subs m loc)))))

   610 

   611 (defn- get-fixed [m e d]

   612   (insert-decimal (expand-fixed m e d) e))

   613 

   614 (defn- insert-scaled-decimal

   615   "Insert the decimal point at the right spot in the number to match an exponent"

   616   [m k]

   617   (if (neg? k)

   618     (str "." m)

   619     (str (subs m 0 k) "." (subs m k))))

   620 

   621 ;; the function to render ~F directives

   622 ;; TODO: support rationals. Back off to ~D/~A is the appropriate cases

   623 (defn- fixed-float [params navigator offsets]

   624   (let [w (:w params)

   625         d (:d params)

   626         [arg navigator] (next-arg navigator)

   627         [sign abs] (if (neg? arg) ["-" (- arg)] ["+" arg])

   628         [mantissa exp] (float-parts abs)

   629         scaled-exp (+ exp (:k params))

   630         add-sign (or (:at params) (neg? arg))

   631         append-zero (and (not d) (<= (dec (count mantissa)) scaled-exp))

   632         [rounded-mantissa scaled-exp expanded] (round-str mantissa scaled-exp 

   633                                                           d (if w (- w (if add-sign 1 0))))

   634         fixed-repr (get-fixed rounded-mantissa (if expanded (inc scaled-exp) scaled-exp) d)

   635         prepend-zero (= (first fixed-repr) \.)]

   636     (if w

   637       (let [len (count fixed-repr)

   638             signed-len (if add-sign (inc len) len)

   639             prepend-zero (and prepend-zero (not (>= signed-len w)))

   640             append-zero (and append-zero (not (>= signed-len w)))

   641             full-len (if (or prepend-zero append-zero)

   642                        (inc signed-len) 

   643                        signed-len)]

   644         (if (and (> full-len w) (:overflowchar params))

   645           (print (apply str (repeat w (:overflowchar params))))

   646           (print (str

   647                   (apply str (repeat (- w full-len) (:padchar params)))

   648                   (if add-sign sign) 

   649                   (if prepend-zero "0")

   650                   fixed-repr

   651                   (if append-zero "0")))))

   652       (print (str

   653               (if add-sign sign) 

   654               (if prepend-zero "0")

   655               fixed-repr

   656               (if append-zero "0"))))

   657     navigator))

   658 

   659 

   660 ;; the function to render ~E directives

   661 ;; TODO: support rationals. Back off to ~D/~A is the appropriate cases

   662 ;; TODO: define ~E representation for Infinity

   663 (defn- exponential-float [params navigator offsets]

   664   (let [[arg navigator] (next-arg navigator)]

   665     (loop [[mantissa exp] (float-parts (if (neg? arg) (- arg) arg))]

   666       (let [w (:w params)

   667             d (:d params)

   668             e (:e params)

   669             k (:k params)

   670             expchar (or (:exponentchar params) \E)

   671             add-sign (or (:at params) (neg? arg))

   672             prepend-zero (<= k 0)

   673             ^Integer scaled-exp (- exp (dec k))

   674             scaled-exp-str (str (Math/abs scaled-exp))

   675             scaled-exp-str (str expchar (if (neg? scaled-exp) \- \+) 

   676                                 (if e (apply str 

   677                                              (repeat 

   678                                               (- e 

   679                                                  (count scaled-exp-str)) 

   680                                               \0))) 

   681                                 scaled-exp-str)

   682             exp-width (count scaled-exp-str)

   683             base-mantissa-width (count mantissa)

   684             scaled-mantissa (str (apply str (repeat (- k) \0))

   685                                  mantissa

   686                                  (if d 

   687                                    (apply str 

   688                                           (repeat 

   689                                            (- d (dec base-mantissa-width)

   690                                               (if (neg? k) (- k) 0)) \0))))

   691             w-mantissa (if w (- w exp-width))

   692             [rounded-mantissa _ incr-exp] (round-str 

   693                                            scaled-mantissa 0

   694                                            (cond

   695                                             (= k 0) (dec d)

   696                                             (pos? k) d

   697                                             (neg? k) (dec d))

   698                                            (if w-mantissa 

   699                                              (- w-mantissa (if add-sign 1 0))))

   700             full-mantissa (insert-scaled-decimal rounded-mantissa k)

   701             append-zero (and (= k (count rounded-mantissa)) (nil? d))]

   702         (if (not incr-exp)

   703           (if w

   704             (let [len (+ (count full-mantissa) exp-width)

   705                   signed-len (if add-sign (inc len) len)

   706                   prepend-zero (and prepend-zero (not (= signed-len w)))

   707                   full-len (if prepend-zero (inc signed-len) signed-len)

   708                   append-zero (and append-zero (< full-len w))]

   709               (if (and (or (> full-len w) (and e (> (- exp-width 2) e)))

   710                        (:overflowchar params))

   711                 (print (apply str (repeat w (:overflowchar params))))

   712                 (print (str

   713                         (apply str 

   714                                (repeat 

   715                                 (- w full-len (if append-zero 1 0) )

   716                                 (:padchar params)))

   717                         (if add-sign (if (neg? arg) \- \+)) 

   718                         (if prepend-zero "0")

   719                         full-mantissa

   720                         (if append-zero "0")

   721                         scaled-exp-str))))

   722             (print (str

   723                     (if add-sign (if (neg? arg) \- \+)) 

   724                     (if prepend-zero "0")

   725                     full-mantissa

   726                     (if append-zero "0")

   727                     scaled-exp-str)))

   728           (recur [rounded-mantissa (inc exp)]))))

   729     navigator))

   730 

   731 ;; the function to render ~G directives

   732 ;; This just figures out whether to pass the request off to ~F or ~E based 

   733 ;; on the algorithm in CLtL.

   734 ;; TODO: support rationals. Back off to ~D/~A is the appropriate cases

   735 ;; TODO: refactor so that float-parts isn't called twice

   736 (defn- general-float [params navigator offsets]

   737   (let [[arg _] (next-arg navigator)

   738         [mantissa exp] (float-parts (if (neg? arg) (- arg) arg))

   739         w (:w params)

   740         d (:d params)

   741         e (:e params)

   742         n (if (= arg 0.0) 0 (inc exp))

   743         ee (if e (+ e 2) 4)

   744         ww (if w (- w ee))

   745         d (if d d (max (count mantissa) (min n 7)))

   746         dd (- d n)]

   747     (if (<= 0 dd d)

   748       (let [navigator (fixed-float {:w ww, :d dd, :k 0, 

   749                                     :overflowchar (:overflowchar params),

   750                                     :padchar (:padchar params), :at (:at params)} 

   751                                    navigator offsets)]

   752         (print (apply str (repeat ee \space)))

   753         navigator)

   754       (exponential-float params navigator offsets))))

   755 

   756 ;; the function to render ~$ directives

   757 ;; TODO: support rationals. Back off to ~D/~A is the appropriate cases

   758 (defn- dollar-float [params navigator offsets]

   759   (let [[^Double arg navigator] (next-arg navigator)

   760         [mantissa exp] (float-parts (Math/abs arg))

   761         d (:d params) ; digits after the decimal

   762         n (:n params) ; minimum digits before the decimal

   763         w (:w params) ; minimum field width

   764         add-sign (or (:at params) (neg? arg))

   765         [rounded-mantissa scaled-exp expanded] (round-str mantissa exp d nil)

   766         ^String fixed-repr (get-fixed rounded-mantissa (if expanded (inc scaled-exp) scaled-exp) d)

   767         full-repr (str (apply str (repeat (- n (.indexOf fixed-repr (int \.))) \0)) fixed-repr)

   768         full-len (+ (count full-repr) (if add-sign 1 0))]

   769     (print (str

   770             (if (and (:colon params) add-sign) (if (neg? arg) \- \+))

   771             (apply str (repeat (- w full-len) (:padchar params)))

   772             (if (and (not (:colon params)) add-sign) (if (neg? arg) \- \+))

   773             full-repr))

   774     navigator))

   775         

   776 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

   777 ;;; Support for the '~[...~]' conditional construct in its

   778 ;;; different flavors

   779 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

   780 

   781 ;; ~[...~] without any modifiers chooses one of the clauses based on the param or 

   782 ;; next argument

   783 ;; TODO check arg is positive int

   784 (defn- choice-conditional [params arg-navigator offsets]

   785   (let [arg (:selector params)

   786         [arg navigator] (if arg [arg arg-navigator] (next-arg arg-navigator))

   787         clauses (:clauses params)

   788         clause (if (or (neg? arg) (>= arg (count clauses)))

   789                  (first (:else params))

   790                  (nth clauses arg))]

   791     (if clause

   792       (execute-sub-format clause navigator (:base-args params))

   793       navigator)))

   794 

   795 ;; ~:[...~] with the colon reads the next argument treating it as a truth value

   796 (defn- boolean-conditional [params arg-navigator offsets]

   797   (let [[arg navigator] (next-arg arg-navigator)

   798         clauses (:clauses params)

   799         clause (if arg

   800                  (second clauses)

   801                  (first clauses))]

   802     (if clause

   803       (execute-sub-format clause navigator (:base-args params))

   804       navigator)))

   805 

   806 ;; ~@[...~] with the at sign executes the conditional if the next arg is not

   807 ;; nil/false without consuming the arg

   808 (defn- check-arg-conditional [params arg-navigator offsets]

   809   (let [[arg navigator] (next-arg arg-navigator)

   810         clauses (:clauses params)

   811         clause (if arg (first clauses))]

   812     (if arg

   813       (if clause

   814         (execute-sub-format clause arg-navigator (:base-args params))

   815         arg-navigator)

   816       navigator)))

   817 

   818 

   819 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

   820 ;;; Support for the '~{...~}' iteration construct in its

   821 ;;; different flavors

   822 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

   823 

   824 

   825 ;; ~{...~} without any modifiers uses the next argument as an argument list that 

   826 ;; is consumed by all the iterations

   827 (defn- iterate-sublist [params navigator offsets]

   828   (let [max-count (:max-iterations params)

   829         param-clause (first (:clauses params))

   830         [clause navigator] (if (empty? param-clause) 

   831                              (get-format-arg navigator)

   832                              [param-clause navigator]) 

   833         [arg-list navigator] (next-arg navigator)

   834         args (init-navigator arg-list)]

   835     (loop [count 0

   836            args args

   837            last-pos (num -1)]

   838       (if (and (not max-count) (= (:pos args) last-pos) (> count 1))

   839         ;; TODO get the offset in here and call format exception

   840         (throw (RuntimeException. "%{ construct not consuming any arguments: Infinite loop!")))

   841       (if (or (and (empty? (:rest args))

   842                    (or (not (:colon (:right-params params))) (> count 0)))

   843               (and max-count (>= count max-count)))

   844         navigator

   845         (let [iter-result (execute-sub-format clause args (:base-args params))] 

   846           (if (= :up-arrow (first iter-result))

   847             navigator

   848             (recur (inc count) iter-result (:pos args))))))))

   849 

   850 ;; ~:{...~} with the colon treats the next argument as a list of sublists. Each of the

   851 ;; sublists is used as the arglist for a single iteration.

   852 (defn- iterate-list-of-sublists [params navigator offsets]

   853   (let [max-count (:max-iterations params)

   854         param-clause (first (:clauses params))

   855         [clause navigator] (if (empty? param-clause) 

   856                              (get-format-arg navigator)

   857                              [param-clause navigator]) 

   858         [arg-list navigator] (next-arg navigator)]

   859     (loop [count 0

   860            arg-list arg-list]

   861       (if (or (and (empty? arg-list)

   862                    (or (not (:colon (:right-params params))) (> count 0)))

   863               (and max-count (>= count max-count)))

   864         navigator

   865         (let [iter-result (execute-sub-format 

   866                            clause 

   867                            (init-navigator (first arg-list))

   868                            (init-navigator (next arg-list)))]

   869           (if (= :colon-up-arrow (first iter-result))

   870             navigator

   871             (recur (inc count) (next arg-list))))))))

   872 

   873 ;; ~@{...~} with the at sign uses the main argument list as the arguments to the iterations

   874 ;; is consumed by all the iterations

   875 (defn- iterate-main-list [params navigator offsets]

   876   (let [max-count (:max-iterations params)

   877         param-clause (first (:clauses params))

   878         [clause navigator] (if (empty? param-clause) 

   879                              (get-format-arg navigator)

   880                              [param-clause navigator])]

   881     (loop [count 0

   882            navigator navigator

   883            last-pos (num -1)]

   884       (if (and (not max-count) (= (:pos navigator) last-pos) (> count 1))

   885         ;; TODO get the offset in here and call format exception

   886         (throw (RuntimeException. "%@{ construct not consuming any arguments: Infinite loop!")))

   887       (if (or (and (empty? (:rest navigator))

   888                    (or (not (:colon (:right-params params))) (> count 0)))

   889               (and max-count (>= count max-count)))

   890         navigator

   891         (let [iter-result (execute-sub-format clause navigator (:base-args params))] 

   892           (if (= :up-arrow (first iter-result))

   893             (second iter-result)

   894             (recur 

   895              (inc count) iter-result (:pos navigator))))))))

   896 

   897 ;; ~@:{...~} with both colon and at sign uses the main argument list as a set of sublists, one

   898 ;; of which is consumed with each iteration

   899 (defn- iterate-main-sublists [params navigator offsets]

   900   (let [max-count (:max-iterations params)

   901         param-clause (first (:clauses params))

   902         [clause navigator] (if (empty? param-clause) 

   903                              (get-format-arg navigator)

   904                              [param-clause navigator]) 

   905         ]

   906     (loop [count 0

   907            navigator navigator]

   908       (if (or (and (empty? (:rest navigator))

   909                    (or (not (:colon (:right-params params))) (> count 0)))

   910               (and max-count (>= count max-count)))

   911         navigator

   912         (let [[sublist navigator] (next-arg-or-nil navigator)

   913               iter-result (execute-sub-format clause (init-navigator sublist) navigator)]

   914           (if (= :colon-up-arrow (first iter-result))

   915             navigator

   916             (recur (inc count) navigator)))))))

   917 

   918 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

   919 ;;; The '~< directive has two completely different meanings

   920 ;;; in the '~<...~>' form it does justification, but with

   921 ;;; ~<...~:>' it represents the logical block operation of the

   922 ;;; pretty printer.

   923 ;;; 

   924 ;;; Unfortunately, the current architecture decides what function

   925 ;;; to call at form parsing time before the sub-clauses have been

   926 ;;; folded, so it is left to run-time to make the decision.

   927 ;;; 

   928 ;;; TODO: make it possible to make these decisions at compile-time.

   929 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

   930 

   931 (declare format-logical-block)

   932 (declare justify-clauses)

   933 

   934 (defn- logical-block-or-justify [params navigator offsets]

   935   (if (:colon (:right-params params))

   936     (format-logical-block params navigator offsets)

   937     (justify-clauses params navigator offsets)))

   938 

   939 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

   940 ;;; Support for the '~<...~>' justification directive

   941 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

   942 

   943 (defn- render-clauses [clauses navigator base-navigator]

   944   (loop [clauses clauses

   945          acc []

   946          navigator navigator]

   947     (if (empty? clauses)

   948       [acc navigator]

   949       (let [clause (first clauses)

   950             [iter-result result-str] (binding [*out* (java.io.StringWriter.)]

   951                                        [(execute-sub-format clause navigator base-navigator) 

   952                                         (.toString *out*)])]

   953         (if (= :up-arrow (first iter-result))

   954           [acc (second iter-result)]

   955           (recur (next clauses) (conj acc result-str) iter-result))))))

   956 

   957 ;; TODO support for ~:; constructions

   958 (defn- justify-clauses [params navigator offsets]

   959   (let [[[eol-str] new-navigator] (when-let [else (:else params)]

   960                                     (render-clauses else navigator (:base-args params)))

   961         navigator (or new-navigator navigator)

   962         [else-params new-navigator] (when-let [p (:else-params params)]

   963                                       (realize-parameter-list p navigator))

   964         navigator (or new-navigator navigator)

   965         min-remaining (or (first (:min-remaining else-params)) 0)

   966         max-columns (or (first (:max-columns else-params))

   967                         (get-max-column *out*))

   968         clauses (:clauses params)

   969         [strs navigator] (render-clauses clauses navigator (:base-args params))

   970         slots (max 1

   971                    (+ (dec (count strs)) (if (:colon params) 1 0) (if (:at params) 1 0)))

   972         chars (reduce + (map count strs))

   973         mincol (:mincol params)

   974         minpad (:minpad params)

   975         colinc (:colinc params)

   976         minout (+ chars (* slots minpad))

   977         result-columns (if (<= minout mincol) 

   978                          mincol

   979                          (+ mincol (* colinc

   980                                       (+ 1 (quot (- minout mincol 1) colinc)))))

   981         total-pad (- result-columns chars)

   982         pad (max minpad (quot total-pad slots))

   983         extra-pad (- total-pad (* pad slots))

   984         pad-str (apply str (repeat pad (:padchar params)))]

   985     (if (and eol-str (> (+ (get-column (:base @@*out*)) min-remaining result-columns) 

   986                         max-columns))

   987       (print eol-str))

   988     (loop [slots slots

   989            extra-pad extra-pad

   990            strs strs

   991            pad-only (or (:colon params)

   992                         (and (= (count strs) 1) (not (:at params))))]

   993       (if (seq strs)

   994         (do

   995           (print (str (if (not pad-only) (first strs))

   996                       (if (or pad-only (next strs) (:at params)) pad-str)

   997                       (if (pos? extra-pad) (:padchar params))))

   998           (recur 

   999            (dec slots)

  1000            (dec extra-pad)

  1001            (if pad-only strs (next strs))

  1002            false))))

  1003     navigator))

  1004 

  1005 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

  1006 ;;; Support for case modification with ~(...~).

  1007 ;;; We do this by wrapping the underlying writer with

  1008 ;;; a special writer to do the appropriate modification. This

  1009 ;;; allows us to support arbitrary-sized output and sources

  1010 ;;; that may block.

  1011 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

  1012 

  1013 (defn- downcase-writer 

  1014   "Returns a proxy that wraps writer, converting all characters to lower case"

  1015   [^java.io.Writer writer]

  1016   (proxy [java.io.Writer] []

  1017     (close [] (.close writer))

  1018     (flush [] (.flush writer))

  1019     (write ([^chars cbuf ^Integer off ^Integer len] 

  1020               (.write writer cbuf off len))

  1021            ([x]

  1022               (condp = (class x)

  1023 		String 

  1024 		(let [s ^String x]

  1025 		  (.write writer (.toLowerCase s)))

  1026 

  1027 		Integer

  1028 		(let [c ^Character x]

  1029 		  (.write writer (int (Character/toLowerCase (char c))))))))))

  1030 

  1031 (defn- upcase-writer 

  1032   "Returns a proxy that wraps writer, converting all characters to upper case"

  1033   [^java.io.Writer writer]

  1034   (proxy [java.io.Writer] []

  1035     (close [] (.close writer))

  1036     (flush [] (.flush writer))

  1037     (write ([^chars cbuf ^Integer off ^Integer len] 

  1038               (.write writer cbuf off len))

  1039            ([x]

  1040               (condp = (class x)

  1041 		String 

  1042 		(let [s ^String x]

  1043 		  (.write writer (.toUpperCase s)))

  1044 

  1045 		Integer

  1046 		(let [c ^Character x]

  1047 		  (.write writer (int (Character/toUpperCase (char c))))))))))

  1048 

  1049 (defn- capitalize-string

  1050   "Capitalizes the words in a string. If first? is false, don't capitalize the 

  1051                                       first character of the string even if it's a letter."

  1052   [s first?]

  1053   (let [^Character f (first s) 

  1054         s (if (and first? f (Character/isLetter f))

  1055             (str (Character/toUpperCase f) (subs s 1))

  1056             s)]

  1057     (apply str 

  1058            (first

  1059             (consume

  1060              (fn [s]

  1061                (if (empty? s)

  1062                  [nil nil]

  1063                  (let [m (re-matcher #"\W\w" s)

  1064                        match (re-find m)

  1065                        offset (and match (inc (.start m)))]

  1066                    (if offset

  1067                      [(str (subs s 0 offset) 

  1068                            (Character/toUpperCase ^Character (nth s offset)))

  1069                       (subs s (inc offset))]

  1070                      [s nil]))))

  1071              s)))))

  1072 

  1073 (defn- capitalize-word-writer

  1074   "Returns a proxy that wraps writer, captializing all words"

  1075   [^java.io.Writer writer]

  1076   (let [last-was-whitespace? (ref true)] 

  1077     (proxy [java.io.Writer] []

  1078       (close [] (.close writer))

  1079       (flush [] (.flush writer))

  1080       (write 

  1081        ([^chars cbuf ^Integer off ^Integer len] 

  1082           (.write writer cbuf off len))

  1083        ([x]

  1084           (condp = (class x)

  1085             String 

  1086             (let [s ^String x]

  1087               (.write writer 

  1088                       ^String (capitalize-string (.toLowerCase s) @last-was-whitespace?))

  1089               (dosync 

  1090                (ref-set last-was-whitespace? 

  1091                         (Character/isWhitespace 

  1092                          ^Character (nth s (dec (count s)))))))

  1093 

  1094             Integer

  1095             (let [c (char x)]

  1096               (let [mod-c (if @last-was-whitespace? (Character/toUpperCase ^Character (char x)) c)] 

  1097                 (.write writer (int mod-c))

  1098                 (dosync (ref-set last-was-whitespace? (Character/isWhitespace ^Character (char x))))))))))))

  1099 

  1100 (defn- init-cap-writer

  1101   "Returns a proxy that wraps writer, capitalizing the first word"

  1102   [^java.io.Writer writer]

  1103   (let [capped (ref false)] 

  1104     (proxy [java.io.Writer] []

  1105       (close [] (.close writer))

  1106       (flush [] (.flush writer))

  1107       (write ([^chars cbuf ^Integer off ^Integer len] 

  1108                 (.write writer cbuf off len))

  1109              ([x]

  1110                 (condp = (class x)

  1111                  String 

  1112                  (let [s (.toLowerCase ^String x)]

  1113                    (if (not @capped) 

  1114                      (let [m (re-matcher #"\S" s)

  1115                            match (re-find m)

  1116                            offset (and match (.start m))]

  1117                        (if offset

  1118                          (do (.write writer 

  1119                                    (str (subs s 0 offset) 

  1120                                         (Character/toUpperCase ^Character (nth s offset))

  1121                                         (.toLowerCase ^String (subs s (inc offset)))))

  1122                            (dosync (ref-set capped true)))

  1123                          (.write writer s))) 

  1124                      (.write writer (.toLowerCase s))))

  1125 

  1126                  Integer

  1127                  (let [c ^Character (char x)]

  1128                    (if (and (not @capped) (Character/isLetter c))

  1129                      (do

  1130                        (dosync (ref-set capped true))

  1131                        (.write writer (int (Character/toUpperCase c))))

  1132                      (.write writer (int (Character/toLowerCase c)))))))))))

  1133 

  1134 (defn- modify-case [make-writer params navigator offsets]

  1135   (let [clause (first (:clauses params))]

  1136     (binding [*out* (make-writer *out*)] 

  1137       (execute-sub-format clause navigator (:base-args params)))))

  1138 

  1139 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

  1140 ;;; If necessary, wrap the writer in a PrettyWriter object

  1141 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

  1142 

  1143 (defn get-pretty-writer [writer]

  1144   (if (pretty-writer? writer) 

  1145     writer

  1146     (pretty-writer writer *print-right-margin* *print-miser-width*)))

  1147  

  1148 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

  1149 ;;; Support for column-aware operations ~&, ~T

  1150 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

  1151 

  1152 ;; TODO: make an automatic newline for non-ColumnWriters

  1153 (defn fresh-line

  1154   "Make a newline if the Writer is not already at the beginning of the line.

  1155 N.B. Only works on ColumnWriters right now."

  1156   []

  1157   (if (not (= 0 (get-column (:base @@*out*))))

  1158     (prn)))

  1159 

  1160 (defn- absolute-tabulation [params navigator offsets]

  1161   (let [colnum (:colnum params) 

  1162         colinc (:colinc params)

  1163         current (get-column (:base @@*out*))

  1164         space-count (cond

  1165                      (< current colnum) (- colnum current)

  1166                      (= colinc 0) 0

  1167                      :else (- colinc (rem (- current colnum) colinc)))]

  1168     (print (apply str (repeat space-count \space))))

  1169   navigator)

  1170 

  1171 (defn- relative-tabulation [params navigator offsets]

  1172   (let [colrel (:colnum params) 

  1173         colinc (:colinc params)

  1174         start-col (+ colrel (get-column (:base @@*out*)))

  1175         offset (if (pos? colinc) (rem start-col colinc) 0)

  1176         space-count (+ colrel (if (= 0 offset) 0 (- colinc offset)))]

  1177     (print (apply str (repeat space-count \space))))

  1178   navigator)

  1179 

  1180 

  1181 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

  1182 ;;; Support for accessing the pretty printer from a format

  1183 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

  1184 

  1185 ;; TODO: support ~@; per-line-prefix separator

  1186 ;; TODO: get the whole format wrapped so we can start the lb at any column

  1187 (defn- format-logical-block [params navigator offsets]

  1188   (let [clauses (:clauses params)

  1189         clause-count (count clauses)

  1190         prefix (cond

  1191                 (> clause-count 1) (:string (:params (first (first clauses))))

  1192                 (:colon params) "(")

  1193         body (nth clauses (if (> clause-count 1) 1 0))

  1194         suffix (cond

  1195                 (> clause-count 2) (:string (:params (first (nth clauses 2))))

  1196                 (:colon params) ")")

  1197         [arg navigator] (next-arg navigator)]

  1198     (pprint-logical-block :prefix prefix :suffix suffix

  1199       (execute-sub-format 

  1200        body 

  1201        (init-navigator arg)

  1202        (:base-args params)))

  1203     navigator))

  1204 

  1205 (defn- set-indent [params navigator offsets]

  1206   (let [relative-to (if (:colon params) :current :block)]

  1207     (pprint-indent relative-to (:n params))

  1208     navigator))

  1209 

  1210 ;;; TODO: support ~:T section options for ~T

  1211 

  1212 (defn- conditional-newline [params navigator offsets]

  1213   (let [kind (if (:colon params) 

  1214                (if (:at params) :mandatory :fill)

  1215                (if (:at params) :miser :linear))]

  1216     (pprint-newline kind)

  1217     navigator))

  1218 

  1219 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

  1220 ;;; The table of directives we support, each with its params,

  1221 ;;; properties, and the compilation function

  1222 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

  1223 

  1224 ;; We start with a couple of helpers

  1225 (defn- process-directive-table-element [ [ char params flags bracket-info & generator-fn ] ]

  1226   [char, 

  1227    {:directive char,

  1228     :params `(array-map ~@params),

  1229     :flags flags,

  1230     :bracket-info bracket-info,

  1231     :generator-fn (concat '(fn [ params offset]) generator-fn) }])

  1232 

  1233 (defmacro ^{:private true}

  1234   defdirectives 

  1235   [ & directives ]

  1236   `(def ^{:private true}

  1237         directive-table (hash-map ~@(mapcat process-directive-table-element directives))))

  1238 

  1239 (defdirectives 

  1240   (\A 

  1241    [ :mincol [0 Integer] :colinc [1 Integer] :minpad [0 Integer] :padchar [\space Character] ] 

  1242    #{ :at :colon :both} {}

  1243    #(format-ascii print-str %1 %2 %3))

  1244 

  1245   (\S 

  1246    [ :mincol [0 Integer] :colinc [1 Integer] :minpad [0 Integer] :padchar [\space Character] ] 

  1247    #{ :at :colon :both} {}

  1248    #(format-ascii pr-str %1 %2 %3))

  1249 

  1250   (\D

  1251    [ :mincol [0 Integer] :padchar [\space Character] :commachar [\, Character] 

  1252     :commainterval [ 3 Integer]]

  1253    #{ :at :colon :both } {}

  1254    #(format-integer 10 %1 %2 %3))

  1255 

  1256   (\B

  1257    [ :mincol [0 Integer] :padchar [\space Character] :commachar [\, Character] 

  1258     :commainterval [ 3 Integer]]

  1259    #{ :at :colon :both } {}

  1260    #(format-integer 2 %1 %2 %3))

  1261 

  1262   (\O

  1263    [ :mincol [0 Integer] :padchar [\space Character] :commachar [\, Character] 

  1264     :commainterval [ 3 Integer]]

  1265    #{ :at :colon :both } {}

  1266    #(format-integer 8 %1 %2 %3))

  1267 

  1268   (\X

  1269    [ :mincol [0 Integer] :padchar [\space Character] :commachar [\, Character] 

  1270     :commainterval [ 3 Integer]]

  1271    #{ :at :colon :both } {}

  1272    #(format-integer 16 %1 %2 %3))

  1273 

  1274   (\R

  1275    [:base [nil Integer] :mincol [0 Integer] :padchar [\space Character] :commachar [\, Character] 

  1276     :commainterval [ 3 Integer]]

  1277    #{ :at :colon :both } {}

  1278    (do

  1279      (cond                          ; ~R is overloaded with bizareness

  1280        (first (:base params))     #(format-integer (:base %1) %1 %2 %3)

  1281        (and (:at params) (:colon params))   #(format-old-roman %1 %2 %3)

  1282        (:at params)               #(format-new-roman %1 %2 %3)

  1283        (:colon params)            #(format-ordinal-english %1 %2 %3)

  1284        true                       #(format-cardinal-english %1 %2 %3))))

  1285 

  1286   (\P

  1287    [ ]

  1288    #{ :at :colon :both } {}

  1289    (fn [params navigator offsets]

  1290      (let [navigator (if (:colon params) (relative-reposition navigator -1) navigator)

  1291            strs (if (:at params) ["y" "ies"] ["" "s"])

  1292            [arg navigator] (next-arg navigator)]

  1293        (print (if (= arg 1) (first strs) (second strs)))

  1294        navigator)))

  1295 

  1296   (\C

  1297    [:char-format [nil Character]]

  1298    #{ :at :colon :both } {}

  1299    (cond

  1300      (:colon params) pretty-character

  1301      (:at params) readable-character

  1302      :else plain-character))

  1303 

  1304   (\F

  1305    [ :w [nil Integer] :d [nil Integer] :k [0 Integer] :overflowchar [nil Character] 

  1306     :padchar [\space Character] ]

  1307    #{ :at } {}

  1308    fixed-float)

  1309 

  1310   (\E

  1311    [ :w [nil Integer] :d [nil Integer] :e [nil Integer] :k [1 Integer] 

  1312     :overflowchar [nil Character] :padchar [\space Character] 

  1313     :exponentchar [nil Character] ]

  1314    #{ :at } {}

  1315    exponential-float)

  1316 

  1317   (\G

  1318    [ :w [nil Integer] :d [nil Integer] :e [nil Integer] :k [1 Integer] 

  1319     :overflowchar [nil Character] :padchar [\space Character] 

  1320     :exponentchar [nil Character] ]

  1321    #{ :at } {}

  1322    general-float)

  1323 

  1324   (\$

  1325    [ :d [2 Integer] :n [1 Integer] :w [0 Integer] :padchar [\space Character]]

  1326    #{ :at :colon :both} {}

  1327    dollar-float)

  1328 

  1329   (\% 

  1330    [ :count [1 Integer] ] 

  1331    #{ } {}

  1332    (fn [params arg-navigator offsets]

  1333      (dotimes [i (:count params)]

  1334        (prn))

  1335      arg-navigator))

  1336 

  1337   (\&

  1338    [ :count [1 Integer] ] 

  1339    #{ :pretty } {}

  1340    (fn [params arg-navigator offsets]

  1341      (let [cnt (:count params)]

  1342        (if (pos? cnt) (fresh-line))

  1343        (dotimes [i (dec cnt)]

  1344          (prn)))

  1345      arg-navigator))

  1346 

  1347   (\| 

  1348    [ :count [1 Integer] ] 

  1349    #{ } {}

  1350    (fn [params arg-navigator offsets]

  1351      (dotimes [i (:count params)]

  1352        (print \formfeed))

  1353      arg-navigator))

  1354 

  1355   (\~ 

  1356    [ :n [1 Integer] ] 

  1357    #{ } {}

  1358    (fn [params arg-navigator offsets]

  1359      (let [n (:n params)]

  1360        (print (apply str (repeat n \~)))

  1361        arg-navigator)))

  1362 

  1363   (\newline ;; Whitespace supression is handled in the compilation loop

  1364    [ ] 

  1365    #{:colon :at} {}

  1366    (fn [params arg-navigator offsets]

  1367      (if (:at params)

  1368        (prn))

  1369      arg-navigator))

  1370 

  1371   (\T

  1372    [ :colnum [1 Integer] :colinc [1 Integer] ] 

  1373    #{ :at :pretty } {}

  1374    (if (:at params)

  1375      #(relative-tabulation %1 %2 %3)

  1376      #(absolute-tabulation %1 %2 %3)))

  1377 

  1378   (\* 

  1379    [ :n [1 Integer] ] 

  1380    #{ :colon :at } {}

  1381    (fn [params navigator offsets]

  1382      (let [n (:n params)]

  1383        (if (:at params)

  1384          (absolute-reposition navigator n)

  1385          (relative-reposition navigator (if (:colon params) (- n) n)))

  1386        )))

  1387 

  1388   (\? 

  1389    [ ] 

  1390    #{ :at } {}

  1391    (if (:at params)

  1392      (fn [params navigator offsets]     ; args from main arg list

  1393        (let [[subformat navigator] (get-format-arg navigator)]

  1394          (execute-sub-format subformat navigator  (:base-args params))))

  1395      (fn [params navigator offsets]     ; args from sub-list

  1396        (let [[subformat navigator] (get-format-arg navigator)

  1397              [subargs navigator] (next-arg navigator)

  1398              sub-navigator (init-navigator subargs)]

  1399          (execute-sub-format subformat sub-navigator (:base-args params))

  1400          navigator))))

  1401        

  1402 

  1403   (\(

  1404    [ ]

  1405    #{ :colon :at :both} { :right \), :allows-separator nil, :else nil }

  1406    (let [mod-case-writer (cond

  1407                            (and (:at params) (:colon params))

  1408                            upcase-writer

  1409 

  1410                            (:colon params)

  1411                            capitalize-word-writer

  1412 

  1413                            (:at params)

  1414                            init-cap-writer

  1415 

  1416                            :else

  1417                            downcase-writer)]

  1418      #(modify-case mod-case-writer %1 %2 %3)))

  1419 

  1420   (\) [] #{} {} nil) 

  1421 

  1422   (\[

  1423    [ :selector [nil Integer] ]

  1424    #{ :colon :at } { :right \], :allows-separator true, :else :last }

  1425    (cond

  1426      (:colon params)

  1427      boolean-conditional

  1428 

  1429      (:at params)

  1430      check-arg-conditional

  1431 

  1432      true

  1433      choice-conditional))

  1434 

  1435   (\; [:min-remaining [nil Integer] :max-columns [nil Integer]] 

  1436    #{ :colon } { :separator true } nil) 

  1437    

  1438   (\] [] #{} {} nil) 

  1439 

  1440   (\{

  1441    [ :max-iterations [nil Integer] ]

  1442    #{ :colon :at :both} { :right \}, :allows-separator false }

  1443    (cond

  1444      (and (:at params) (:colon params))

  1445      iterate-main-sublists

  1446 

  1447      (:colon params)

  1448      iterate-list-of-sublists

  1449 

  1450      (:at params)

  1451      iterate-main-list

  1452 

  1453      true

  1454      iterate-sublist))

  1455 

  1456    

  1457   (\} [] #{:colon} {} nil) 

  1458 

  1459   (\<

  1460    [:mincol [0 Integer] :colinc [1 Integer] :minpad [0 Integer] :padchar [\space Character]]

  1461    #{:colon :at :both :pretty} { :right \>, :allows-separator true, :else :first }

  1462    logical-block-or-justify)

  1463 

  1464   (\> [] #{:colon} {} nil) 

  1465 

  1466   ;; TODO: detect errors in cases where colon not allowed

  1467   (\^ [:arg1 [nil Integer] :arg2 [nil Integer] :arg3 [nil Integer]] 

  1468    #{:colon} {} 

  1469    (fn [params navigator offsets]

  1470      (let [arg1 (:arg1 params)

  1471            arg2 (:arg2 params)

  1472            arg3 (:arg3 params)

  1473            exit (if (:colon params) :colon-up-arrow :up-arrow)]

  1474        (cond

  1475          (and arg1 arg2 arg3)

  1476          (if (<= arg1 arg2 arg3) [exit navigator] navigator)

  1477 

  1478          (and arg1 arg2)

  1479          (if (= arg1 arg2) [exit navigator] navigator)

  1480 

  1481          arg1

  1482          (if (= arg1 0) [exit navigator] navigator)

  1483 

  1484          true     ; TODO: handle looking up the arglist stack for info

  1485          (if (if (:colon params) 

  1486                (empty? (:rest (:base-args params)))

  1487                (empty? (:rest navigator)))

  1488            [exit navigator] navigator))))) 

  1489 

  1490   (\W 

  1491    [] 

  1492    #{:at :colon :both} {}

  1493    (if (or (:at params) (:colon params))

  1494      (let [bindings (concat

  1495                      (if (:at params) [:level nil :length nil] [])

  1496                      (if (:colon params) [:pretty true] []))]

  1497        (fn [params navigator offsets]

  1498          (let [[arg navigator] (next-arg navigator)]

  1499            (if (apply write arg bindings)

  1500              [:up-arrow navigator]

  1501              navigator))))

  1502      (fn [params navigator offsets]

  1503        (let [[arg navigator] (next-arg navigator)]

  1504          (if (write-out arg)

  1505            [:up-arrow navigator]

  1506            navigator)))))

  1507 

  1508   (\_

  1509    []

  1510    #{:at :colon :both} {}

  1511    conditional-newline)

  1512 

  1513   (\I

  1514    [:n [0 Integer]]

  1515    #{:colon} {}

  1516    set-indent)

  1517   )

  1518 

  1519 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

  1520 ;;; Code to manage the parameters and flags associated with each

  1521 ;;; directive in the format string.

  1522 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

  1523 

  1524 (def ^{:private true}

  1525      param-pattern #"^([vV]|#|('.)|([+-]?\d+)|(?=,))")

  1526 (def ^{:private true}

  1527      special-params #{ :parameter-from-args :remaining-arg-count })

  1528 

  1529 (defn- extract-param [[s offset saw-comma]]

  1530   (let [m (re-matcher param-pattern s)

  1531         param (re-find m)]

  1532     (if param

  1533       (let [token-str (first (re-groups m))

  1534             remainder (subs s (.end m))

  1535             new-offset (+ offset (.end m))]

  1536         (if (not (= \, (nth remainder 0)))

  1537           [ [token-str offset] [remainder new-offset false]]

  1538           [ [token-str offset] [(subs remainder 1) (inc new-offset) true]]))

  1539       (if saw-comma 

  1540         (format-error "Badly formed parameters in format directive" offset)

  1541         [ nil [s offset]]))))

  1542 

  1543 

  1544 (defn- extract-params [s offset] 

  1545   (consume extract-param [s offset false]))

  1546 

  1547 (defn- translate-param

  1548   "Translate the string representation of a param to the internalized

  1549                                       representation"

  1550   [[^String p offset]]

  1551   [(cond 

  1552     (= (.length p) 0) nil

  1553     (and (= (.length p) 1) (contains? #{\v \V} (nth p 0))) :parameter-from-args

  1554     (and (= (.length p) 1) (= \# (nth p 0))) :remaining-arg-count

  1555     (and (= (.length p) 2) (= \' (nth p 0))) (nth p 1)

  1556     true (new Integer p))

  1557    offset])

  1558  

  1559 (def ^{:private true}

  1560      flag-defs { \: :colon, \@ :at })

  1561 

  1562 (defn- extract-flags [s offset]

  1563   (consume

  1564    (fn [[s offset flags]]

  1565      (if (empty? s)

  1566        [nil [s offset flags]]

  1567        (let [flag (get flag-defs (first s))]

  1568          (if flag

  1569            (if (contains? flags flag)

  1570              (format-error 

  1571               (str "Flag \"" (first s) "\" appears more than once in a directive")

  1572               offset)

  1573              [true [(subs s 1) (inc offset) (assoc flags flag [true offset])]])

  1574            [nil [s offset flags]]))))

  1575    [s offset {}]))

  1576 

  1577 (defn- check-flags [def flags]

  1578   (let [allowed (:flags def)]

  1579     (if (and (not (:at allowed)) (:at flags))

  1580       (format-error (str "\"@\" is an illegal flag for format directive \"" (:directive def) "\"")

  1581                     (nth (:at flags) 1)))

  1582     (if (and (not (:colon allowed)) (:colon flags))

  1583       (format-error (str "\":\" is an illegal flag for format directive \"" (:directive def) "\"")

  1584                     (nth (:colon flags) 1)))

  1585     (if (and (not (:both allowed)) (:at flags) (:colon flags))

  1586       (format-error (str "Cannot combine \"@\" and \":\" flags for format directive \"" 

  1587                          (:directive def) "\"")

  1588                     (min (nth (:colon flags) 1) (nth (:at flags) 1))))))

  1589 

  1590 (defn- map-params

  1591   "Takes a directive definition and the list of actual parameters and

  1592 a map of flags and returns a map of the parameters and flags with defaults

  1593 filled in. We check to make sure that there are the right types and number

  1594 of parameters as well."

  1595   [def params flags offset]

  1596   (check-flags def flags)

  1597   (if (> (count params) (count (:params def)))

  1598     (format-error 

  1599      (cl-format 

  1600       nil 

  1601       "Too many parameters for directive \"~C\": ~D~:* ~[were~;was~:;were~] specified but only ~D~:* ~[are~;is~:;are~] allowed"

  1602       (:directive def) (count params) (count (:params def)))

  1603      (second (first params))))

  1604   (doall

  1605    (map #(let [val (first %1)]

  1606            (if (not (or (nil? val) (contains? special-params val) 

  1607                         (instance? (second (second %2)) val)))

  1608              (format-error (str "Parameter " (name (first %2))

  1609                                 " has bad type in directive \"" (:directive def) "\": "

  1610                                 (class val))

  1611                            (second %1))) )

  1612         params (:params def)))

  1613      

  1614   (merge                                ; create the result map

  1615    (into (array-map) ; start with the default values, make sure the order is right

  1616          (reverse (for [[name [default]] (:params def)] [name [default offset]])))

  1617    (reduce #(apply assoc %1 %2) {} (filter #(first (nth % 1)) (zipmap (keys (:params def)) params))) ; add the specified parameters, filtering out nils

  1618    flags))                                ; and finally add the flags

  1619 

  1620 (defn- compile-directive [s offset]

  1621   (let [[raw-params [rest offset]] (extract-params s offset)

  1622         [_ [rest offset flags]] (extract-flags rest offset)

  1623         directive (first rest)

  1624         def (get directive-table (Character/toUpperCase ^Character directive))

  1625         params (if def (map-params def (map translate-param raw-params) flags offset))]

  1626     (if (not directive)

  1627       (format-error "Format string ended in the middle of a directive" offset))

  1628     (if (not def)

  1629       (format-error (str "Directive \"" directive "\" is undefined") offset))

  1630     [(struct compiled-directive ((:generator-fn def) params offset) def params offset)

  1631      (let [remainder (subs rest 1) 

  1632            offset (inc offset)

  1633            trim? (and (= \newline (:directive def))

  1634                       (not (:colon params)))

  1635            trim-count (if trim? (prefix-count remainder [\space \tab]) 0)

  1636            remainder (subs remainder trim-count)

  1637            offset (+ offset trim-count)]

  1638        [remainder offset])]))

  1639     

  1640 (defn- compile-raw-string [s offset]

  1641   (struct compiled-directive (fn [_ a _] (print s) a) nil { :string s } offset))

  1642 

  1643 (defn- right-bracket [this] (:right (:bracket-info (:def this))))

  1644 (defn- separator? [this] (:separator (:bracket-info (:def this))))

  1645 (defn- else-separator? [this] 

  1646   (and (:separator (:bracket-info (:def this)))

  1647        (:colon (:params this))))

  1648   

  1649 

  1650 (declare collect-clauses)

  1651 

  1652 (defn- process-bracket [this remainder]

  1653   (let [[subex remainder] (collect-clauses (:bracket-info (:def this))

  1654                                            (:offset this) remainder)]

  1655     [(struct compiled-directive 

  1656              (:func this) (:def this) 

  1657              (merge (:params this) (tuple-map subex (:offset this)))

  1658              (:offset this))

  1659      remainder]))

  1660 

  1661 (defn- process-clause [bracket-info offset remainder]

  1662   (consume 

  1663    (fn [remainder]

  1664      (if (empty? remainder)

  1665        (format-error "No closing bracket found." offset)

  1666        (let [this (first remainder)

  1667              remainder (next remainder)]

  1668          (cond

  1669           (right-bracket this)

  1670           (process-bracket this remainder)

  1671 

  1672           (= (:right bracket-info) (:directive (:def this)))

  1673           [ nil [:right-bracket (:params this) nil remainder]]

  1674 

  1675           (else-separator? this)

  1676           [nil [:else nil (:params this) remainder]]

  1677 

  1678           (separator? this)

  1679           [nil [:separator nil nil remainder]] ;; TODO: check to make sure that there are no params on ~;

  1680 

  1681           true

  1682           [this remainder]))))

  1683    remainder))

  1684 

  1685 (defn- collect-clauses [bracket-info offset remainder]

  1686   (second

  1687    (consume

  1688     (fn [[clause-map saw-else remainder]]

  1689       (let [[clause [type right-params else-params remainder]] 

  1690             (process-clause bracket-info offset remainder)]

  1691         (cond

  1692          (= type :right-bracket)

  1693          [nil [(merge-with concat clause-map 

  1694                            {(if saw-else :else :clauses) [clause] 

  1695                             :right-params right-params})

  1696                remainder]]

  1697 

  1698          (= type :else)

  1699          (cond

  1700           (:else clause-map)

  1701           (format-error "Two else clauses (\"~:;\") inside bracket construction." offset)

  1702          

  1703           (not (:else bracket-info))

  1704           (format-error "An else clause (\"~:;\") is in a bracket type that doesn't support it." 

  1705                         offset)

  1706 

  1707           (and (= :first (:else bracket-info)) (seq (:clauses clause-map)))

  1708           (format-error

  1709            "The else clause (\"~:;\") is only allowed in the first position for this directive." 

  1710            offset)

  1711          

  1712           true         ; if the ~:; is in the last position, the else clause

  1713                                         ; is next, this was a regular clause

  1714           (if (= :first (:else bracket-info))

  1715             [true [(merge-with concat clause-map { :else [clause] :else-params else-params})

  1716                    false remainder]]

  1717             [true [(merge-with concat clause-map { :clauses [clause] })

  1718                    true remainder]]))

  1719 

  1720          (= type :separator)

  1721          (cond

  1722           saw-else

  1723           (format-error "A plain clause (with \"~;\") follows an else clause (\"~:;\") inside bracket construction." offset)

  1724          

  1725           (not (:allows-separator bracket-info))

  1726           (format-error "A separator (\"~;\") is in a bracket type that doesn't support it." 

  1727                         offset)

  1728          

  1729           true

  1730           [true [(merge-with concat clause-map { :clauses [clause] })

  1731                  false remainder]]))))

  1732     [{ :clauses [] } false remainder])))

  1733 

  1734 (defn- process-nesting

  1735   "Take a linearly compiled format and process the bracket directives to give it 

  1736    the appropriate tree structure"

  1737   [format]

  1738   (first

  1739    (consume 

  1740     (fn [remainder]

  1741       (let [this (first remainder)

  1742             remainder (next remainder)

  1743             bracket (:bracket-info (:def this))]

  1744         (if (:right bracket)

  1745           (process-bracket this remainder)

  1746           [this remainder])))

  1747     format)))

  1748 

  1749 (defn compile-format 

  1750   "Compiles format-str into a compiled format which can be used as an argument

  1751 to cl-format just like a plain format string. Use this function for improved 

  1752 performance when you're using the same format string repeatedly"

  1753   [ format-str ]

  1754 ;  (prlabel compiling format-str)

  1755   (binding [*format-str* format-str]

  1756     (process-nesting

  1757      (first 

  1758       (consume 

  1759        (fn [[^String s offset]]

  1760          (if (empty? s)

  1761            [nil s]

  1762            (let [tilde (.indexOf s (int \~))]

  1763              (cond

  1764               (neg? tilde) [(compile-raw-string s offset) ["" (+ offset (.length s))]]

  1765               (zero? tilde)  (compile-directive (subs s 1) (inc offset))

  1766               true 

  1767               [(compile-raw-string (subs s 0 tilde) offset) [(subs s tilde) (+ tilde offset)]]))))

  1768        [format-str 0])))))

  1769 

  1770 (defn- needs-pretty 

  1771   "determine whether a given compiled format has any directives that depend on the

  1772 column number or pretty printing"

  1773   [format]

  1774   (loop [format format]

  1775     (if (empty? format)

  1776       false

  1777       (if (or (:pretty (:flags (:def (first format))))

  1778               (some needs-pretty (first (:clauses (:params (first format)))))

  1779               (some needs-pretty (first (:else (:params (first format))))))

  1780         true

  1781         (recur (next format))))))

  1782 

  1783 (defn execute-format 

  1784   "Executes the format with the arguments. This should never be used directly, but is public

  1785 because the formatter macro uses it."

  1786   {:skip-wiki true}

  1787   ([stream format args]

  1788      (let [^java.io.Writer real-stream (cond 

  1789                                          (not stream) (java.io.StringWriter.)

  1790                                          (true? stream) *out*

  1791                                          :else stream)

  1792            ^java.io.Writer wrapped-stream (if (and (needs-pretty format) 

  1793                                                     (not (pretty-writer? real-stream)))

  1794                                              (get-pretty-writer real-stream)

  1795                                              real-stream)]

  1796        (binding [*out* wrapped-stream]

  1797          (try

  1798           (execute-format format args)

  1799           (finally

  1800            (if-not (identical? real-stream wrapped-stream)

  1801              (.flush wrapped-stream))))

  1802          (if (not stream) (.toString real-stream)))))

  1803   ([format args]

  1804      (map-passing-context 

  1805       (fn [element context]

  1806         (if (abort? context)

  1807           [nil context]

  1808           (let [[params args] (realize-parameter-list 

  1809                                (:params element) context)

  1810                 [params offsets] (unzip-map params)

  1811                 params (assoc params :base-args args)]

  1812             [nil (apply (:func element) [params args offsets])])))

  1813       args

  1814       format)))

  1815 

  1816 

  1817 (defmacro formatter

  1818   "Makes a function which can directly run format-in. The function is

  1819 fn [stream & args] ... and returns nil unless the stream is nil (meaning 

  1820 output to a string) in which case it returns the resulting string.

  1821 

  1822 format-in can be either a control string or a previously compiled format."

  1823   [format-in]

  1824   (let [cf (gensym "compiled-format")]

  1825     `(let [format-in# ~format-in]

  1826        (do (defonce ~cf (if (string? format-in#) (compile-format format-in#) format-in#))

  1827            (fn [stream# & args#]

  1828              (let [navigator# (init-navigator args#)]

  1829                (execute-format stream# ~cf navigator#)))))))

  1830 

  1831 (defmacro formatter-out

  1832   "Makes a function which can directly run format-in. The function is

  1833 fn [& args] ... and returns nil. This version of the formatter macro is

  1834 designed to be used with *out* set to an appropriate Writer. In particular,

  1835 this is meant to be used as part of a pretty printer dispatch method.

  1836 

  1837 format-in can be either a control string or a previously compiled format."

  1838   [format-in]

  1839   (let [cf (gensym "compiled-format")]

  1840     `(let [format-in# ~format-in]

  1841        (do (defonce ~cf (if (string? format-in#) (compile-format format-in#) format-in#))

  1842            (fn [& args#]

  1843              (let [navigator# (init-navigator args#)]

  1844                (execute-format ~cf navigator#)))))))
author	Robert McIntyre <rlm@mit.edu>
date	Sat, 21 Aug 2010 06:25:44 -0400
parents
children