├── .gitignore ├── README.md ├── cljs-710.patch ├── docs └── README.md ├── externs └── highlight.ext.js ├── project.clj ├── push-report.sh ├── report.jpg ├── resources ├── report │ ├── css │ │ ├── highlight-github.css │ │ └── main.css │ ├── index.html │ ├── index_prod.html │ ├── js │ │ └── highlight.pack.js │ ├── progress.edn │ └── welcome.md └── test │ ├── phantomjs-shims.js │ ├── unit-test.html │ └── unit-test.js ├── src ├── clj │ ├── README │ ├── pprint.clj │ └── pprint │ │ ├── cl_format.clj │ │ ├── column_writer.clj │ │ ├── dispatch.clj │ │ ├── pprint_base.clj │ │ ├── pretty_writer.clj │ │ ├── print_table.clj │ │ └── utilities.clj ├── cljs │ └── cljs │ │ ├── pprint.clj │ │ └── pprint.cljs ├── parse │ └── parse │ │ └── core.clj ├── report │ └── report │ │ └── core.cljs └── report_dev │ └── report │ └── dev.cljs └── test ├── clj ├── README ├── pprint.clj └── pprint │ ├── .test_cl_format.clj.swp │ ├── .test_pretty.clj.swp │ ├── test_cl_format.clj │ ├── test_helper.clj │ └── test_pretty.clj └── cljs └── cljs ├── pprint_test.clj └── pprint_test.cljs /.gitignore: -------------------------------------------------------------------------------- 1 | 2 | *.swp 3 | 4 | resources/report/js/out 5 | resources/report/js/out-prod 6 | resources/report/js/report.js 7 | resources/report/js/report.js.map 8 | resources/report/js/report-prod.js 9 | resources/report/forms.edn 10 | 11 | resources/test/out 12 | resources/test/pprint.test.js 13 | resources/test/pprint.test.js.map 14 | 15 | target/ 16 | 17 | figwheel_server.log 18 | 19 | hosted/ 20 | 21 | .idea/ 22 | *.iml 23 | *.nrepl* -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # cljs-pprint 2 | 3 | __NOTE: successfully merged into ClojureScript at version 0.0-3255.__ 4 | 5 | CLJS needs a pretty printer - Clojure has two pretty-printers available, which are being ported to ClojureScript: 6 | 7 | - [`clojure.pprint`](https://clojure.github.io/clojure/clojure.pprint-api.html) - (comprehensive printer) being ported to cljs here, required by [CLJS-710](http://dev.clojure.org/jira/browse/CLJS-710) 8 | - [`fipp`](https://github.com/brandonbloom/fipp) - (lightweight & fast) being ported to cljs at [fipp issue 7](https://github.com/brandonbloom/fipp/issues/7). 9 | 10 | ## Overview 11 | 12 | - `src/clj` and `test/clj` has the original clojure pprint 13 | - `src/cljs` and `test/cljs` has the in-progress clojurescript pprint 14 | - `src/parse` parses aforementioned source directories to generate data for a comparison report 15 | - `src/report` page that displays a progress/comparison report and welcome page 16 | 17 | [See docs for more notes](docs/) 18 | 19 | ## Running the tests 20 | 21 | Node.js must be installed. 22 | 23 | ```sh 24 | lein cljsbuild once test 25 | ``` 26 | 27 | ## Running 28 | 29 | ```sh 30 | # runs the parse tool 31 | lein run 32 | 33 | # runs report server at http://localhost:3449 34 | rlwrap lein figwheel report 35 | ``` 36 | 37 | ## Report 38 | 39 | See the progress report here: 40 | 41 | [![report](report.jpg)](http://shaunlebron.github.io/cljs-pprint) 42 | 43 | -------------------------------------------------------------------------------- /docs/README.md: -------------------------------------------------------------------------------- 1 | # Docs 2 | 3 | Writing notes and plans here. 4 | 5 | ## diff plan 6 | 7 | Creating a diff aid to easily show changes between pprint in clj and cljs. 8 | Should help debugging and review: 9 | 10 | - use clojure.tools.reader/analyzer to get text of each function/macro/var 11 | - build index of functions/macros implemented 12 | 13 | - dump each function (start to end lines) to a separate file 14 | - run wdiff with the (-w -x -y -z args set to span tags with classes) 15 | - output wdiff result to a result html file, with newlines replaced with br 16 | - create result page (anchor links for each tag, and ToC) 17 | 18 | # Thoughts 19 | 20 | ## pprint function changes 21 | 22 | The original `pprint` requires an output `java.io.Writer` writer as its second arg, which 23 | defaults to `*out*`. `*out*` is unimplemented in ClojureScript. The [print section in cljs.core](https://github.com/shaunlebron/cljs-pprint/blob/master/src/cljs/cljs/core.cljs#L7701) 24 | shows the print functions use an IWriter interface. I followed the patterns of the different print 25 | functions to create a basis for pprint usage: 26 | 27 | - __`pprint`__ pretty-prints to `*print-fn*` 28 | - __`pprint-str`__ pretty-prints to a string 29 | - __`pprint-sb`__ pretty-prints to a `goog.StringBuffer` 30 | - __`pprint*`__ pretty-prints to a given `IWriter` 31 | 32 | ## macro file 33 | 34 | In order to port the macros, I have to create a separate `pprint.clj` file to hold them. 35 | 36 | ## pretty-writer changes 37 | 38 | The pretty-writer constructor creates a `proxy` object that can be deref'd to 39 | access a `ref` collection of fields. I could port this to `reify` and `atom`, 40 | respectively, but I need to take a look around to see why these are needed. I 41 | feel compelled to evaluate whether a `deftype` is more suitable here because it 42 | looks it provides mutable fields with protocol implementation. 43 | 44 | ## Char->Int casting? 45 | 46 | Not sure why the casting of `\newline` is done in `c-write-char` but not in 47 | `p-write-char`. Makes me wonder why ints are treated as characters here and 48 | how its behavior may differ in JS. 49 | 50 | ## replacing structs with records 51 | 52 | I replaced the logical-block struct with a record since structs are obsoleted. 53 | Need to see if it's being mutated. 54 | 55 | ## custom deftype macro 56 | 57 | not sure what to do with this yet. used to create a custom constructor 58 | `make-buffer-blob`. 59 | 60 | ## Misc 61 | 62 | - no `(in-ns)` in cljs, so all of clojure.pprint will have to be in the same file 63 | 64 | # References 65 | 66 | - [original clojure.pprint source](https://github.com/clojure/clojure/tree/master/src/clj/clojure/pprint) 67 | - [original clojure.pprint api](https://clojure.github.io/clojure/clojure.pprint-api.html) 68 | - [differences between CLJ and CLJS](https://github.com/clojure/clojurescript/wiki/Differences-from-Clojure) 69 | 70 | ``` 71 | from #clojurescript freenode (IRC) 72 | 73 | [13:56] anyone working on porting pprint to clojurescript? 74 | [13:58] shaunlebron: no one has stepped up to tackle that beast, a patch would be most welcome 75 | [14:00] dnolen_: would you take a patch that just ported the simple dispatch for pretty-printing data? 76 | [14:01] shaunlebron: as long as it's done so that it doesn't cause problem for some one who wants to finish the pretty printing support 77 | ``` 78 | -------------------------------------------------------------------------------- /externs/highlight.ext.js: -------------------------------------------------------------------------------- 1 | 2 | var hljs = {}; 3 | hljs.highlight = function (name, value, ignore_illegals, continuation) {} 4 | hljs.highlightAuto = function (text, languageSubset) {} 5 | hljs.fixMarkup = function (value) {} 6 | hljs.highlightBlock = function (block) {} 7 | hljs.configure = function (user_options) {} 8 | hljs.initHighlighting = function () {} 9 | hljs.initHighlightingOnLoad = function () {} 10 | hljs.registerLanguage = function (name, language) {} 11 | hljs.listLanguages = function () {} 12 | hljs.getLanguage = function (name) {} 13 | hljs.inherit = function (parent, obj) {} 14 | 15 | -------------------------------------------------------------------------------- /project.clj: -------------------------------------------------------------------------------- 1 | (defproject cljs-pprint "0.1.0-SNAPSHOT" 2 | 3 | :description "clojure.pprint ported to clojurescript" 4 | :url "https://github.com/shaunlebron/cljs-pprint" 5 | :license {:name "Eclipse Public License" 6 | :url "http://www.eclipse.org/legal/epl-v10.html"} 7 | 8 | :dependencies [[org.clojure/clojure "1.7.0-beta2"] 9 | [org.clojure/clojurescript "0.0-3211"] 10 | [org.clojure/core.async "0.1.346.0-17112a-alpha"] 11 | [hiccups "0.3.0"] 12 | [fipp "0.5.2"] 13 | [figwheel "0.2.9"] 14 | [cljs-ajax "0.3.10"] 15 | [markdown-clj "0.9.62"] 16 | [cljsjs/jquery "1.9.0-0"]] 17 | 18 | :plugins [[lein-cljsbuild "1.0.5"] 19 | [lein-figwheel "0.2.9"]] 20 | 21 | :source-paths ["src/parse"] 22 | :main parse.core 23 | 24 | :clean-targets ^{:protect false} ["resources/test/out" 25 | "resources/test/pprint.test.js" 26 | "resources/test/pprint.test.js.map" 27 | "resources/report/js/out" 28 | "resources/report/js/report.js"] 29 | 30 | :cljsbuild 31 | {:test-commands {"test" ["node" :runner "resources/test/pprint.test.js"]} 32 | 33 | :builds 34 | [{:id "test" 35 | :source-paths ["src/cljs" "test/cljs"] 36 | :notify-command ["node" "resources/test/pprint.test.js"] 37 | :compiler 38 | {:output-to "resources/test/pprint.test.js" 39 | :source-map "resources/test/pprint.test.js.map" 40 | :output-dir "resources/test/out" 41 | :optimizations :simple}} 42 | 43 | {:id "report" 44 | :source-paths ["src/report" "src/report_dev"] 45 | :compiler 46 | {:output-to "resources/report/js/report.js" 47 | :output-dir "resources/report/js/out" 48 | :optimizations :none 49 | :source-map true}} 50 | 51 | {:id "report-prod" 52 | :source-paths ["src/report"] 53 | :compiler 54 | {:output-to "resources/report/js/report-prod.js" 55 | :output-dir "resources/report/js/out-prod" 56 | :optimizations :advanced 57 | :externs ["externs/highlight.ext.js"]}} 58 | 59 | ]} 60 | 61 | :figwheel 62 | {:http-server-root "report" 63 | :css-dirs "resources/report"} 64 | 65 | ) 66 | -------------------------------------------------------------------------------- /push-report.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | set -e 4 | 5 | cd `dirname $0` 6 | 7 | if [ ! -d hosted ]; then 8 | git clone git@github.com:shaunlebron/cljs-pprint.git hosted 9 | fi 10 | 11 | cd hosted 12 | 13 | # checkout gh-pages branch 14 | git checkout gh-pages 15 | 16 | # make sure gh-pages is up-to-date 17 | git pull 18 | 19 | # remove all files 20 | git rm -rf . 21 | 22 | # add new report files 23 | lein cljsbuild once report-prod 24 | cp -r ../resources/report/* . 25 | 26 | # clean out unneeded 27 | rm -rf js/out-prod \ 28 | js/out \ 29 | js/report.js 30 | 31 | # choose production page 32 | mv index_prod.html index.html 33 | 34 | git add . 35 | git commit -m "auto-update" 36 | 37 | # publish to website 38 | git push 39 | 40 | -------------------------------------------------------------------------------- /report.jpg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/shaunlebron/cljs-pprint/30d57cef96e477ac05aa265d2bd54d7768a0c8e5/report.jpg -------------------------------------------------------------------------------- /resources/report/css/highlight-github.css: -------------------------------------------------------------------------------- 1 | /* 2 | 3 | github.com style (c) Vasily Polovnyov 4 | 5 | */ 6 | 7 | .hljs { 8 | display: block; 9 | overflow-x: auto; 10 | padding: 0.5em; 11 | color: #333; 12 | background: #f8f8f8; 13 | -webkit-text-size-adjust: none; 14 | } 15 | 16 | .hljs-comment, 17 | .diff .hljs-header, 18 | .hljs-javadoc { 19 | color: #998; 20 | font-style: italic; 21 | } 22 | 23 | .hljs-keyword, 24 | .css .rule .hljs-keyword, 25 | .hljs-winutils, 26 | .nginx .hljs-title, 27 | .hljs-subst, 28 | .hljs-request, 29 | .hljs-status { 30 | color: #333; 31 | font-weight: bold; 32 | } 33 | 34 | .hljs-number, 35 | .hljs-hexcolor, 36 | .ruby .hljs-constant { 37 | color: #008080; 38 | } 39 | 40 | .hljs-string, 41 | .hljs-tag .hljs-value, 42 | .hljs-phpdoc, 43 | .hljs-dartdoc, 44 | .tex .hljs-formula { 45 | color: #d14; 46 | } 47 | 48 | .hljs-title, 49 | .hljs-id, 50 | .scss .hljs-preprocessor { 51 | color: #900; 52 | font-weight: bold; 53 | } 54 | 55 | .hljs-list .hljs-keyword, 56 | .hljs-subst { 57 | font-weight: normal; 58 | } 59 | 60 | .hljs-class .hljs-title, 61 | .hljs-type, 62 | .vhdl .hljs-literal, 63 | .tex .hljs-command { 64 | color: #458; 65 | font-weight: bold; 66 | } 67 | 68 | .hljs-tag, 69 | .hljs-tag .hljs-title, 70 | .hljs-rules .hljs-property, 71 | .django .hljs-tag .hljs-keyword { 72 | color: #000080; 73 | font-weight: normal; 74 | } 75 | 76 | .hljs-attribute, 77 | .hljs-variable, 78 | .lisp .hljs-body { 79 | color: #008080; 80 | } 81 | 82 | .hljs-regexp { 83 | color: #009926; 84 | } 85 | 86 | .hljs-symbol, 87 | .ruby .hljs-symbol .hljs-string, 88 | .lisp .hljs-keyword, 89 | .clojure .hljs-keyword, 90 | .scheme .hljs-keyword, 91 | .tex .hljs-special, 92 | .hljs-prompt { 93 | color: #990073; 94 | } 95 | 96 | .hljs-built_in { 97 | color: #0086b3; 98 | } 99 | 100 | .hljs-preprocessor, 101 | .hljs-pragma, 102 | .hljs-pi, 103 | .hljs-doctype, 104 | .hljs-shebang, 105 | .hljs-cdata { 106 | color: #999; 107 | font-weight: bold; 108 | } 109 | 110 | .hljs-deletion { 111 | background: #fdd; 112 | } 113 | 114 | .hljs-addition { 115 | background: #dfd; 116 | } 117 | 118 | .diff .hljs-change { 119 | background: #0086b3; 120 | } 121 | 122 | .hljs-chunk { 123 | color: #aaa; 124 | } 125 | -------------------------------------------------------------------------------- /resources/report/css/main.css: -------------------------------------------------------------------------------- 1 | @import url(http://fonts.googleapis.com/css?family=Roboto+Slab:400,700,300); 2 | @import url(http://fonts.googleapis.com/css?family=Open+Sans:400,700); 3 | @import url(http://fonts.googleapis.com/css?family=Inconsolata); 4 | 5 | body { 6 | margin: 0; 7 | background-color: #f7f7f7; 8 | font-family: 'Open Sans', sans-serif; 9 | } 10 | 11 | pre code { 12 | font-family: 'Inconsolata', monospace; 13 | } 14 | 15 | /*****************************************************/ 16 | 17 | div.header { 18 | padding:40px 80px; 19 | width: 840px; 20 | } 21 | 22 | div.header h1 { 23 | font-family: 'Roboto Slab', serif; 24 | font-weight: 300; 25 | color: #333; 26 | margin-bottom: 0; 27 | } 28 | 29 | div.header h1 b { 30 | font-weight: 400; 31 | } 32 | 33 | div.header p, 34 | div.header li { 35 | color: #888; 36 | max-width: 800px; 37 | line-height: 1.6em; 38 | } 39 | 40 | div.header li { 41 | list-style-type: square; 42 | } 43 | 44 | div.header p:nth-child(2) { 45 | margin-top: 0; 46 | } 47 | 48 | div.header p b { 49 | color: #555; 50 | } 51 | 52 | div.header pre { 53 | margin: 50px 0; 54 | padding: 20px; 55 | background-color: #fff; 56 | border-top: 1px solid #EEE; 57 | border-left: 1px solid #DDD; 58 | border-right: 1px solid #EEE; 59 | border-bottom: 1px solid #DDD; 60 | } 61 | 62 | div.header pre code { 63 | background-color: #fff; 64 | } 65 | 66 | div.header h1 a { 67 | font-size: 0.5em; 68 | vertical-align: middle; 69 | } 70 | 71 | div.header a { 72 | text-decoration: none; 73 | color: #0074d9; 74 | } 75 | 76 | /*****************************************************/ 77 | 78 | div.toc { 79 | padding:80px; 80 | background-color: #fff; 81 | width: 100%; 82 | } 83 | 84 | div.toc h2 { 85 | font-family: 'Roboto Slab', serif; 86 | font-weight: 300; 87 | } 88 | 89 | div.toc p { 90 | color: #888; 91 | font-size: 0.8em; 92 | } 93 | 94 | div.toc .file-table { 95 | margin-top: 30px; 96 | } 97 | 98 | div.toc .file-table > td { 99 | padding-left: 20px; 100 | } 101 | 102 | div.toc .file-table td { 103 | font-size: 0.8em; 104 | color: #444; 105 | vertical-align: top; 106 | } 107 | 108 | div.toc .def-table td { 109 | list-style-type: none; 110 | color: #AAA; 111 | } 112 | 113 | div.toc .def-table td:last-child { 114 | min-width: 80px; 115 | } 116 | 117 | div.toc .def-table td.num { 118 | text-align: right; 119 | color: #CCC; 120 | } 121 | 122 | div.toc h3 { 123 | font-family: 'Roboto Slab', serif; 124 | font-weight: normal; 125 | font-size: 0.93em; 126 | } 127 | 128 | .toc-link { 129 | text-decoration: none; 130 | color: #45C05A; 131 | } 132 | 133 | /*****************************************************/ 134 | 135 | div.code-compare-section { 136 | } 137 | 138 | table.code-compare-table { 139 | border-collapse: collapse; 140 | } 141 | 142 | table.code-compare-table tr.header-row td h1 { 143 | font-family: 'Roboto Slab', serif; 144 | font-size: 2em; 145 | font-weight: 300; 146 | color: #333; 147 | margin-bottom: 0; 148 | } 149 | 150 | table.code-compare-table tr.header-row td { 151 | color: #777; 152 | } 153 | 154 | table.code-compare-table > tbody > tr > td:first-child { 155 | padding-left: 80px; 156 | } 157 | 158 | table.code-compare-table > tbody > tr > td { 159 | padding: 40px 20px; 160 | color: #555; 161 | font-size: 0.9em; 162 | vertical-align: top; 163 | } 164 | 165 | table.code-compare-table tr.header { 166 | border-top: 4px solid #fff; 167 | } 168 | 169 | table.code-compare-table tr.header > td { 170 | padding-bottom: 0; 171 | } 172 | 173 | table.code-compare-table .func-name { 174 | color: #333; 175 | font-size: 1.2em; 176 | font-weight: bold; 177 | font-family: 'Inconsolata', monospace; 178 | } 179 | 180 | table.code-compare-table .func-head { 181 | color: #AAA; 182 | } 183 | 184 | a.def-anchor { 185 | position: relative; 186 | text-decoration: none; 187 | } 188 | 189 | a.def-anchor:hover:before { 190 | font-family: 'FontAwesome'; 191 | line-height: 19px; 192 | color: #AAA; 193 | position: absolute; 194 | left: -20px; 195 | /* hex codes here: http://fortawesome.github.io/Font-Awesome/cheatsheet/ */ 196 | content: "\f0c1"; 197 | } 198 | 199 | table.code-block td.lines code { 200 | text-align: right; 201 | color: #CCC; 202 | } 203 | -------------------------------------------------------------------------------- /resources/report/index.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 |
9 | 10 | 11 | 12 | 13 | 14 | 15 | 16 | -------------------------------------------------------------------------------- /resources/report/index_prod.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 |
9 | 10 | 11 | 12 | 13 | -------------------------------------------------------------------------------- /resources/report/js/highlight.pack.js: -------------------------------------------------------------------------------- 1 | !function(e){"undefined"!=typeof exports?e(exports):(window.hljs=e({}),"function"==typeof define&&define.amd&&define([],function(){return window.hljs}))}(function(e){function n(e){return e.replace(/&/gm,"&").replace(//gm,">")}function t(e){return e.nodeName.toLowerCase()}function r(e,n){var t=e&&e.exec(n);return t&&0==t.index}function a(e){var n=(e.className+" "+(e.parentNode?e.parentNode.className:"")).split(/\s+/);return n=n.map(function(e){return e.replace(/^lang(uage)?-/,"")}),n.filter(function(e){return N(e)||/no(-?)highlight/.test(e)})[0]}function o(e,n){var t={};for(var r in e)t[r]=e[r];if(n)for(var r in n)t[r]=n[r];return t}function i(e){var n=[];return function r(e,a){for(var o=e.firstChild;o;o=o.nextSibling)3==o.nodeType?a+=o.nodeValue.length:1==o.nodeType&&(n.push({event:"start",offset:a,node:o}),a=r(o,a),t(o).match(/br|hr|img|input/)||n.push({event:"stop",offset:a,node:o}));return a}(e,0),n}function c(e,r,a){function o(){return e.length&&r.length?e[0].offset!=r[0].offset?e[0].offset"}function c(e){l+=""}function u(e){("start"==e.event?i:c)(e.node)}for(var s=0,l="",f=[];e.length||r.length;){var g=o();if(l+=n(a.substr(s,g[0].offset-s)),s=g[0].offset,g==e){f.reverse().forEach(c);do u(g.splice(0,1)[0]),g=o();while(g==e&&g.length&&g[0].offset==s);f.reverse().forEach(i)}else"start"==g[0].event?f.push(g[0].node):f.pop(),u(g.splice(0,1)[0])}return l+n(a.substr(s))}function u(e){function n(e){return e&&e.source||e}function t(t,r){return RegExp(n(t),"m"+(e.cI?"i":"")+(r?"g":""))}function r(a,i){if(!a.compiled){if(a.compiled=!0,a.k=a.k||a.bK,a.k){var c={},u=function(n,t){e.cI&&(t=t.toLowerCase()),t.split(" ").forEach(function(e){var t=e.split("|");c[t[0]]=[n,t[1]?Number(t[1]):1]})};"string"==typeof a.k?u("keyword",a.k):Object.keys(a.k).forEach(function(e){u(e,a.k[e])}),a.k=c}a.lR=t(a.l||/\b[A-Za-z0-9_]+\b/,!0),i&&(a.bK&&(a.b="\\b("+a.bK.split(" ").join("|")+")\\b"),a.b||(a.b=/\B|\b/),a.bR=t(a.b),a.e||a.eW||(a.e=/\B|\b/),a.e&&(a.eR=t(a.e)),a.tE=n(a.e)||"",a.eW&&i.tE&&(a.tE+=(a.e?"|":"")+i.tE)),a.i&&(a.iR=t(a.i)),void 0===a.r&&(a.r=1),a.c||(a.c=[]);var s=[];a.c.forEach(function(e){e.v?e.v.forEach(function(n){s.push(o(e,n))}):s.push("self"==e?a:e)}),a.c=s,a.c.forEach(function(e){r(e,a)}),a.starts&&r(a.starts,i);var l=a.c.map(function(e){return e.bK?"\\.?("+e.b+")\\.?":e.b}).concat([a.tE,a.i]).map(n).filter(Boolean);a.t=l.length?t(l.join("|"),!0):{exec:function(){return null}}}}r(e)}function s(e,t,a,o){function i(e,n){for(var t=0;t";return o+=e+'">',o+n+i}function d(){if(!w.k)return n(y);var e="",t=0;w.lR.lastIndex=0;for(var r=w.lR.exec(y);r;){e+=n(y.substr(t,r.index-t));var a=g(w,r);a?(B+=a[1],e+=p(a[0],n(r[0]))):e+=n(r[0]),t=w.lR.lastIndex,r=w.lR.exec(y)}return e+n(y.substr(t))}function h(){if(w.sL&&!R[w.sL])return n(y);var e=w.sL?s(w.sL,y,!0,L[w.sL]):l(y);return w.r>0&&(B+=e.r),"continuous"==w.subLanguageMode&&(L[w.sL]=e.top),p(e.language,e.value,!1,!0)}function v(){return void 0!==w.sL?h():d()}function b(e,t){var r=e.cN?p(e.cN,"",!0):"";e.rB?(M+=r,y=""):e.eB?(M+=n(t)+r,y=""):(M+=r,y=t),w=Object.create(e,{parent:{value:w}})}function m(e,t){if(y+=e,void 0===t)return M+=v(),0;var r=i(t,w);if(r)return M+=v(),b(r,t),r.rB?0:t.length;var a=c(w,t);if(a){var o=w;o.rE||o.eE||(y+=t),M+=v();do w.cN&&(M+=""),B+=w.r,w=w.parent;while(w!=a.parent);return o.eE&&(M+=n(t)),y="",a.starts&&b(a.starts,""),o.rE?0:t.length}if(f(t,w))throw new Error('Illegal lexeme "'+t+'" for mode "'+(w.cN||"")+'"');return y+=t,t.length||1}var x=N(e);if(!x)throw new Error('Unknown language: "'+e+'"');u(x);for(var w=o||x,L={},M="",k=w;k!=x;k=k.parent)k.cN&&(M=p(k.cN,"",!0)+M);var y="",B=0;try{for(var C,j,I=0;;){if(w.t.lastIndex=I,C=w.t.exec(t),!C)break;j=m(t.substr(I,C.index-I),C[0]),I=C.index+j}m(t.substr(I));for(var k=w;k.parent;k=k.parent)k.cN&&(M+="");return{r:B,value:M,language:e,top:w}}catch(A){if(-1!=A.message.indexOf("Illegal"))return{r:0,value:n(t)};throw A}}function l(e,t){t=t||E.languages||Object.keys(R);var r={r:0,value:n(e)},a=r;return t.forEach(function(n){if(N(n)){var t=s(n,e,!1);t.language=n,t.r>a.r&&(a=t),t.r>r.r&&(a=r,r=t)}}),a.language&&(r.second_best=a),r}function f(e){return E.tabReplace&&(e=e.replace(/^((<[^>]+>|\t)+)/gm,function(e,n){return n.replace(/\t/g,E.tabReplace)})),E.useBR&&(e=e.replace(/\n/g,"
")),e}function g(e,n,t){var r=n?x[n]:t,a=[e.trim()];return e.match(/(\s|^)hljs(\s|$)/)||a.push("hljs"),r&&a.push(r),a.join(" ").trim()}function p(e){var n=a(e);if(!/no(-?)highlight/.test(n)){var t;E.useBR?(t=document.createElementNS("http://www.w3.org/1999/xhtml","div"),t.innerHTML=e.innerHTML.replace(/\n/g,"").replace(//g,"\n")):t=e;var r=t.textContent,o=n?s(n,r,!0):l(r),u=i(t);if(u.length){var p=document.createElementNS("http://www.w3.org/1999/xhtml","div");p.innerHTML=o.value,o.value=c(u,i(p),r)}o.value=f(o.value),e.innerHTML=o.value,e.className=g(e.className,n,o.language),e.result={language:o.language,re:o.r},o.second_best&&(e.second_best={language:o.second_best.language,re:o.second_best.r})}}function d(e){E=o(E,e)}function h(){if(!h.called){h.called=!0;var e=document.querySelectorAll("pre code");Array.prototype.forEach.call(e,p)}}function v(){addEventListener("DOMContentLoaded",h,!1),addEventListener("load",h,!1)}function b(n,t){var r=R[n]=t(e);r.aliases&&r.aliases.forEach(function(e){x[e]=n})}function m(){return Object.keys(R)}function N(e){return R[e]||R[x[e]]}var E={classPrefix:"hljs-",tabReplace:null,useBR:!1,languages:void 0},R={},x={};return e.highlight=s,e.highlightAuto=l,e.fixMarkup=f,e.highlightBlock=p,e.configure=d,e.initHighlighting=h,e.initHighlightingOnLoad=v,e.registerLanguage=b,e.listLanguages=m,e.getLanguage=N,e.inherit=o,e.IR="[a-zA-Z][a-zA-Z0-9_]*",e.UIR="[a-zA-Z_][a-zA-Z0-9_]*",e.NR="\\b\\d+(\\.\\d+)?",e.CNR="(\\b0[xX][a-fA-F0-9]+|(\\b\\d+(\\.\\d*)?|\\.\\d+)([eE][-+]?\\d+)?)",e.BNR="\\b(0b[01]+)",e.RSR="!|!=|!==|%|%=|&|&&|&=|\\*|\\*=|\\+|\\+=|,|-|-=|/=|/|:|;|<<|<<=|<=|<|===|==|=|>>>=|>>=|>=|>>>|>>|>|\\?|\\[|\\{|\\(|\\^|\\^=|\\||\\|=|\\|\\||~",e.BE={b:"\\\\[\\s\\S]",r:0},e.ASM={cN:"string",b:"'",e:"'",i:"\\n",c:[e.BE]},e.QSM={cN:"string",b:'"',e:'"',i:"\\n",c:[e.BE]},e.PWM={b:/\b(a|an|the|are|I|I'm|isn't|don't|doesn't|won't|but|just|should|pretty|simply|enough|gonna|going|wtf|so|such)\b/},e.CLCM={cN:"comment",b:"//",e:"$",c:[e.PWM]},e.CBCM={cN:"comment",b:"/\\*",e:"\\*/",c:[e.PWM]},e.HCM={cN:"comment",b:"#",e:"$",c:[e.PWM]},e.NM={cN:"number",b:e.NR,r:0},e.CNM={cN:"number",b:e.CNR,r:0},e.BNM={cN:"number",b:e.BNR,r:0},e.CSSNM={cN:"number",b:e.NR+"(%|em|ex|ch|rem|vw|vh|vmin|vmax|cm|mm|in|pt|pc|px|deg|grad|rad|turn|s|ms|Hz|kHz|dpi|dpcm|dppx)?",r:0},e.RM={cN:"regexp",b:/\//,e:/\/[gimuy]*/,i:/\n/,c:[e.BE,{b:/\[/,e:/\]/,r:0,c:[e.BE]}]},e.TM={cN:"title",b:e.IR,r:0},e.UTM={cN:"title",b:e.UIR,r:0},e});hljs.registerLanguage("clojure",function(e){var t={built_in:"def cond apply if-not if-let if not not= = < > <= >= == + / * - rem quot neg? pos? delay? symbol? keyword? true? false? integer? empty? coll? list? set? ifn? fn? associative? sequential? sorted? counted? reversible? number? decimal? class? distinct? isa? float? rational? reduced? ratio? odd? even? char? seq? vector? string? map? nil? contains? zero? instance? not-every? not-any? libspec? -> ->> .. . inc compare do dotimes mapcat take remove take-while drop letfn drop-last take-last drop-while while intern condp case reduced cycle split-at split-with repeat replicate iterate range merge zipmap declare line-seq sort comparator sort-by dorun doall nthnext nthrest partition eval doseq await await-for let agent atom send send-off release-pending-sends add-watch mapv filterv remove-watch agent-error restart-agent set-error-handler error-handler set-error-mode! error-mode shutdown-agents quote var fn loop recur throw try monitor-enter monitor-exit defmacro defn defn- macroexpand macroexpand-1 for dosync and or when when-not when-let comp juxt partial sequence memoize constantly complement identity assert peek pop doto proxy defstruct first rest cons defprotocol cast coll deftype defrecord last butlast sigs reify second ffirst fnext nfirst nnext defmulti defmethod meta with-meta ns in-ns create-ns import refer keys select-keys vals key val rseq name namespace promise into transient persistent! conj! assoc! dissoc! pop! disj! use class type num float double short byte boolean bigint biginteger bigdec print-method print-dup throw-if printf format load compile get-in update-in pr pr-on newline flush read slurp read-line subvec with-open memfn time re-find re-groups rand-int rand mod locking assert-valid-fdecl alias resolve ref deref refset swap! reset! set-validator! compare-and-set! alter-meta! reset-meta! commute get-validator alter ref-set ref-history-count ref-min-history ref-max-history ensure sync io! new next conj set! to-array future future-call into-array aset gen-class reduce map filter find empty hash-map hash-set sorted-map sorted-map-by sorted-set sorted-set-by vec vector seq flatten reverse assoc dissoc list disj get union difference intersection extend extend-type extend-protocol int nth delay count concat chunk chunk-buffer chunk-append chunk-first chunk-rest max min dec unchecked-inc-int unchecked-inc unchecked-dec-inc unchecked-dec unchecked-negate unchecked-add-int unchecked-add unchecked-subtract-int unchecked-subtract chunk-next chunk-cons chunked-seq? prn vary-meta lazy-seq spread list* str find-keyword keyword symbol gensym force rationalize"},r="a-zA-Z_\\-!.?+*=<>&#'",n="["+r+"]["+r+"0-9/;:]*",a="[-+]?\\d+(\\.\\d+)?",o={b:n,r:0},s={cN:"number",b:a,r:0},c=e.inherit(e.QSM,{i:null}),i={cN:"comment",b:";",e:"$",r:0},d={cN:"literal",b:/\b(true|false|nil)\b/},l={cN:"collection",b:"[\\[\\{]",e:"[\\]\\}]"},m={cN:"comment",b:"\\^"+n},p={cN:"comment",b:"\\^\\{",e:"\\}"},u={cN:"attribute",b:"[:]"+n},f={cN:"list",b:"\\(",e:"\\)"},h={eW:!0,r:0},y={k:t,l:n,cN:"keyword",b:n,starts:h},b=[f,c,m,p,i,u,l,s,d,o];return f.c=[{cN:"comment",b:"comment"},y,h],h.c=b,l.c=b,{aliases:["clj"],i:/\S/,c:[f,c,m,p,i,u,l,s,d]}});hljs.registerLanguage("clojure-repl",function(){return{c:[{cN:"prompt",b:/^([\w.-]+|\s*#_)=>/,starts:{e:/$/,sL:"clojure",subLanguageMode:"continuous"}}]}}); -------------------------------------------------------------------------------- /resources/report/progress.edn: -------------------------------------------------------------------------------- 1 | {"with-pretty-writer" :same-name 2 | "getf" :same-name 3 | "setf" :same-name 4 | "pretty-writer" :same-name 5 | "pprint" :same-name 6 | "set-pprint-dispatch" :same-name 7 | "with-pprint-dispatch" :same-name 8 | "pretty-writer?" :same-name 9 | "make-pretty-writer" :same-name 10 | "*print-right-margin*" :same-name 11 | "*print-miser-width*" :same-name 12 | "*print-pretty*" :same-name 13 | "*print-pprint-dispatch*" :same-name 14 | "*print-lines*" :same-name 15 | "*print-circle*" :same-name 16 | "*print-shared*" :same-name 17 | "*print-suppress-namespaces*" :same-name 18 | "*print-radix*" :same-name 19 | "*print-base*" :same-name 20 | "*current-level*" :same-name 21 | "*current-length*" :same-name 22 | "PrettyFlush" "IPrettyFlush" 23 | "*default-page-width*" :same-name 24 | "get-field" :same-name 25 | "set-field" :same-name 26 | "get-column" :same-name 27 | "get-line" :same-name 28 | "get-max-column" :same-name 29 | "set-max-column" :same-name 30 | "get-writer" :same-name 31 | "c-write-char" :same-name 32 | "column-writer" :same-name 33 | "logical-block" :same-name 34 | "write-initial-lines" :same-name 35 | "get-miser-width" :same-name 36 | "ancestor?" :same-name 37 | "buffer-length" :same-name 38 | "pp-newline" :same-name 39 | "write-token" :same-name 40 | "write-token :start-block-t" :same-name 41 | "write-token :end-block-t" :same-name 42 | "write-token :indent-t" :same-name 43 | "write-token :buffer-blob" :same-name 44 | "write-token :nl-t" :same-name 45 | "write-tokens" :same-name 46 | "tokens-fit?" :same-name 47 | "linear-nl?" :same-name 48 | "miser-nl?" :same-name 49 | "emit-nl?" :same-name 50 | "emit-nl? :linear" :same-name 51 | "emit-nl? :miser" :same-name 52 | "emit-nl? :fill" :same-name 53 | "emit-nl? :mandatory" :same-name 54 | "get-section" :same-name 55 | "get-sub-section" :same-name 56 | "update-nl-state" :same-name 57 | "emit-nl" :same-name 58 | "split-at-newline" :same-name 59 | "write-token-string" :same-name 60 | "write-line" :same-name 61 | "p-write-char" :same-name 62 | "start-block" :same-name 63 | "end-block" :same-name 64 | "nl" :same-name 65 | "indent" :same-name 66 | "map-passing-context" :same-name 67 | "consume" :same-name 68 | "consume-while" :same-name 69 | "unzip-map" :same-name 70 | "tuple-map" :same-name 71 | "rtrim" :same-name 72 | "ltrim" :same-name 73 | "prefix-count" :same-name 74 | "add-to-buffer" :same-name 75 | "write-buffered-output" :same-name 76 | "write-white-space" :same-name 77 | "deftype" :same-name 78 | "buffer-blob" :same-name 79 | "nl-t" :same-name 80 | "start-block-t" :same-name 81 | "end-block-t" :same-name 82 | "indent-t" :same-name 83 | "check-enumerated-arg" :same-name 84 | "level-exceeded" :same-name 85 | "pprint-newline" :same-name 86 | "write-out" :same-name 87 | "write" :same-name 88 | "parse-lb-options" :same-name 89 | "pprint-logical-block" :same-name 90 | "pll-mod-body" :same-name 91 | "print-length-loop" :same-name 92 | "use-method" :same-name 93 | "pprint-vector" :same-name 94 | "pprint-map" :same-name 95 | "simple-dispatch" :same-name 96 | "cl-format" :same-name 97 | "*format-str*" :same-name 98 | "format-error" :same-name 99 | "arg-navigator" :same-name 100 | "init-navigator" :same-name 101 | "next-arg" :same-name 102 | "next-arg-or-nil" :same-name 103 | "get-format-arg" :same-name 104 | "absolute-reposition" :same-name 105 | "relative-reposition" :same-name 106 | "compiled-directive" :same-name 107 | "realize-parameter" :same-name 108 | "realize-parameter-list" :same-name 109 | "special-radix-markers" :same-name 110 | "format-simple-number" :same-name 111 | "format-ascii" :same-name 112 | "integral?" :same-name 113 | "remainders" :same-name 114 | "base-str" :same-name 115 | "java-base-formats" "javascript-base-formats" 116 | "opt-base-str" :same-name 117 | "group-by*" :same-name 118 | "format-integer" :same-name 119 | "english-cardinal-units" :same-name 120 | "english-ordinal-units" :same-name 121 | "english-cardinal-tens" :same-name 122 | "english-ordinal-tens" :same-name 123 | "english-scale-numbers" :same-name 124 | "format-simple-cardinal" :same-name 125 | "add-english-scales" :same-name 126 | "format-cardinal-english" :same-name 127 | "format-simple-ordinal" :same-name 128 | "format-ordinal-english" :same-name 129 | "old-roman-table" :same-name 130 | "new-roman-table" :same-name 131 | "format-roman" :same-name 132 | "format-old-roman" :same-name 133 | "format-new-roman" :same-name 134 | "special-chars" :same-name 135 | "pretty-character" :same-name 136 | "readable-character" :same-name 137 | "plain-character" :same-name 138 | "abort?" :same-name 139 | "execute-sub-format" :same-name 140 | "float-parts-base" :same-name 141 | "float-parts" :same-name 142 | "inc-s" :same-name 143 | "round-str" :same-name 144 | "expand-fixed" :same-name 145 | "insert-decimal" :same-name 146 | "get-fixed" :same-name 147 | "insert-scaled-decimal" :same-name 148 | "convert-ratio" :same-name 149 | "fixed-float" :same-name 150 | "exponential-float" :same-name 151 | "general-float" :same-name 152 | "dollar-float" :same-name 153 | "choice-conditional" :same-name 154 | "boolean-conditional" :same-name 155 | "check-arg-conditional" :same-name 156 | "iterate-sublist" :same-name 157 | "iterate-list-of-sublists" :same-name 158 | "iterate-main-list" :same-name 159 | "iterate-main-sublists" :same-name 160 | "logical-block-or-justify" :same-name 161 | "render-clauses" :same-name 162 | "justify-clauses" :same-name 163 | "downcase-writer" :same-name 164 | "upcase-writer" :same-name 165 | "capitalize-string" :same-name 166 | "capitalize-word-writer" :same-name 167 | "init-cap-writer" :same-name 168 | "modify-case" :same-name 169 | "get-pretty-writer" :same-name 170 | "fresh-line" :same-name 171 | "absolute-tabulation" :same-name 172 | "relative-tabulation" :same-name 173 | "pprint-indent" :same-name 174 | "pprint-tab" :same-name 175 | "format-logical-block" :same-name 176 | "set-indent" :same-name 177 | "conditional-newline" :same-name 178 | "process-directive-table-element" :same-name 179 | "defdirectives" :same-name 180 | "param-pattern" :same-name 181 | "special-params" :same-name 182 | "extract-param" :same-name 183 | "extract-params" :same-name 184 | "translate-param" :same-name 185 | "flag-defs" :same-name 186 | "extract-flags" :same-name 187 | "check-flags" :same-name 188 | "map-params" :same-name 189 | "compile-directive" :same-name 190 | "compile-raw-string" :same-name 191 | "right-bracket" :same-name 192 | "separator?" :same-name 193 | "else-separator?" :same-name 194 | "process-bracket" :same-name 195 | "process-clause" :same-name 196 | "collect-clauses" :same-name 197 | "process-nesting" :same-name 198 | "compile-format" :same-name 199 | "needs-pretty" :same-name 200 | "execute-format" :same-name 201 | "cached-compile" :same-name 202 | "formatter" :same-name 203 | "formatter-out" :same-name 204 | "table-ize" :same-name 205 | "write-option-table" :same-name 206 | "print-table" :same-name 207 | "reader-macros" :same-name 208 | "pprint-reader-macro" :same-name 209 | "pprint-simple-list" :same-name 210 | "pprint-list" :same-name 211 | "pprint-vector" :same-name 212 | "pprint-array" :same-name 213 | "pprint-set" :same-name 214 | "type-map" :same-name 215 | "map-ref-type" :same-name 216 | "pprint-ideref" :same-name 217 | "pprint-pqueue" :same-name 218 | "pprint-simple-default" :same-name 219 | "brackets" :same-name 220 | "pprint-ns-reference" :same-name 221 | "pprint-ns" :same-name 222 | "pprint-hold-first" :same-name 223 | "single-defn" :same-name 224 | "multi-defn" :same-name 225 | "pprint-defn" :same-name 226 | "pprint-binding-form" :same-name 227 | "pprint-let" :same-name 228 | "pprint-if" :same-name 229 | "pprint-cond" :same-name 230 | "pprint-condp" :same-name 231 | "*symbol-map*" :same-name 232 | "pprint-anon-func" :same-name 233 | "pprint-simple-code-list" :same-name 234 | "two-forms" :same-name 235 | "add-core-ns" :same-name 236 | "*code-table*" :same-name 237 | "pprint-code-list" :same-name 238 | "pprint-code-symbol" :same-name 239 | "code-dispatch" :same-name 240 | } 241 | -------------------------------------------------------------------------------- /resources/report/welcome.md: -------------------------------------------------------------------------------- 1 | # ClojureScript needs a __pretty printer!__ 2 | 3 | <> 4 | 5 | ```clojure 6 | ;; ugly 7 | user=> data 8 | {:hello "world", :things {:vegetables #{"cauliflower" "sprouts" "cucumber"}, :primes [2 3 5 7 11 9 | 13 17 19 23], :fruits #{"apple" "banana" "strawberry" "kiwi"}}} 10 | 11 | ;; pretty! 12 | user=> (pprint data) 13 | {:hello "world", 14 | :things 15 | {:vegetables #{"cauliflower" "sprouts" "cucumber"}, 16 | :primes [2 3 5 7 11 13 17 19 23], 17 | :fruits #{"apple" "banana" "strawberry" "kiwi"}}} 18 | ``` 19 | 20 | __Why?__ 21 | 22 | Data is at the core of any ClojureScript application. We should be able to see 23 | it clearly! 24 | 25 | __How?__ 26 | 27 | We are porting the 28 | [clojure.pprint](https://clojure.github.io/clojure/clojure.pprint-api.html) 29 | library from Clojure to ClojureScript. ([official tracker](http://dev.clojure.org/jira/browse/CLJS-710)) 30 | 31 | __Why this page?__ 32 | 33 | Porting clojure.pprint has been an unexpectedly large task. I built this page 34 | to help track the differences between the original and ported functions, as 35 | well as track the defs/functions left to be ported. And to make it easier to 36 | involve the community. 37 | 38 | __How can I help?__ 39 | 40 | You can use the progress map below to find functions to port, or use the 41 | side-by-side section to help review the current ports. Be sure to fill out the 42 | Clojure [Contributor Agreement](http://clojure.org/contributing). 43 | 44 | __Alternative/Related projects?__ 45 | 46 | - [pretty-print.net](http://pretty-print.net) an online Clojure/EDN pretty-printer 47 | - [fipp](https://github.com/brandonbloom/fipp) is a faster, more idiomatic, less featured EDN 48 | printer being [ported](https://github.com/brandonbloom/fipp/issues/7) to 49 | ClojureScript. 50 | - [cljs-devtools](https://github.com/binaryage/cljs-devtools) is 51 | a work in progress for inspecting ClojureScript data in the Chrome 52 | console. 53 | - [ankha](https://github.com/noprompt/ankha) is a data inspection component for 54 | Om that allows you view and edit data. 55 | 56 | 57 | 58 | -------------------------------------------------------------------------------- /resources/test/phantomjs-shims.js: -------------------------------------------------------------------------------- 1 | (function() { 2 | 3 | var Ap = Array.prototype; 4 | var slice = Ap.slice; 5 | var Fp = Function.prototype; 6 | 7 | if (!Fp.bind) { 8 | // PhantomJS doesn't support Function.prototype.bind natively, so 9 | // polyfill it whenever this module is required. 10 | Fp.bind = function(context) { 11 | var func = this; 12 | var args = slice.call(arguments, 1); 13 | 14 | function bound() { 15 | var invokedAsConstructor = func.prototype && (this instanceof func); 16 | return func.apply( 17 | // Ignore the context parameter when invoking the bound function 18 | // as a constructor. Note that this includes not only constructor 19 | // invocations using the new keyword but also calls to base class 20 | // constructors such as BaseClass.call(this, ...) or super(...). 21 | !invokedAsConstructor && context || this, 22 | args.concat(slice.call(arguments)) 23 | ); 24 | } 25 | 26 | // The bound function must share the .prototype of the unbound 27 | // function so that any object created by one constructor will count 28 | // as an instance of both constructors. 29 | bound.prototype = func.prototype; 30 | 31 | return bound; 32 | }; 33 | } 34 | 35 | })(); 36 | -------------------------------------------------------------------------------- /resources/test/unit-test.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | -------------------------------------------------------------------------------- /resources/test/unit-test.js: -------------------------------------------------------------------------------- 1 | 2 | var page = require('webpage').create(); 3 | var url = phantom.args[0]; 4 | 5 | page.onConsoleMessage = function (message) { 6 | console.log(message); 7 | }; 8 | 9 | function exit(code) { 10 | setTimeout(function(){ phantom.exit(code); }, 0); 11 | phantom.onError = function(){}; 12 | } 13 | 14 | console.log("Loading URL: " + url); 15 | 16 | page.open(url, function (status) { 17 | if (status != "success") { 18 | console.log('Failed to open ' + url); 19 | phantom.exit(1); 20 | } 21 | 22 | console.log("Running test."); 23 | 24 | var result = page.evaluate(function() { 25 | return test_runner.runner(); 26 | }); 27 | 28 | if (result != 0) { 29 | console.log("*** Test failed! ***"); 30 | exit(1); 31 | } 32 | else { 33 | console.log("Test succeeded."); 34 | exit(0); 35 | } 36 | 37 | }); 38 | -------------------------------------------------------------------------------- /src/clj/README: -------------------------------------------------------------------------------- 1 | This is the original clojure.pprint implementation, duplicated here only for reference. 2 | -------------------------------------------------------------------------------- /src/clj/pprint.clj: -------------------------------------------------------------------------------- 1 | ;;; pprint.clj -- Pretty printer and Common Lisp compatible format function (cl-format) 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 | (ns 15 | ^{:author "Tom Faulhaber", 16 | :doc "A Pretty Printer for Clojure 17 | 18 | clojure.pprint implements a flexible system for printing structured data 19 | in a pleasing, easy-to-understand format. Basic use of the pretty printer is 20 | simple, just call pprint instead of println. More advanced users can use 21 | the building blocks provided to create custom output formats. 22 | 23 | Out of the box, pprint supports a simple structured format for basic data 24 | and a specialized format for Clojure source code. More advanced formats, 25 | including formats that don't look like Clojure data at all like XML and 26 | JSON, can be rendered by creating custom dispatch functions. 27 | 28 | In addition to the pprint function, this module contains cl-format, a text 29 | formatting function which is fully compatible with the format function in 30 | Common Lisp. Because pretty printing directives are directly integrated with 31 | cl-format, it supports very concise custom dispatch. It also provides 32 | a more powerful alternative to Clojure's standard format function. 33 | 34 | See documentation for pprint and cl-format for more information or 35 | complete documentation on the the clojure web site on github.", 36 | :added "1.2"} 37 | clojure.pprint 38 | (:refer-clojure :exclude (deftype)) 39 | (:use [clojure.walk :only [walk]])) 40 | 41 | 42 | (load "pprint/utilities") 43 | (load "pprint/column_writer") 44 | (load "pprint/pretty_writer") 45 | (load "pprint/pprint_base") 46 | (load "pprint/cl_format") 47 | (load "pprint/dispatch") 48 | (load "pprint/print_table") 49 | 50 | nil 51 | -------------------------------------------------------------------------------- /src/clj/pprint/column_writer.clj: -------------------------------------------------------------------------------- 1 | ;;; column_writer.clj -- part of the pretty printer for Clojure 2 | 3 | 4 | ; Copyright (c) Rich Hickey. All rights reserved. 5 | ; The use and distribution terms for this software are covered by the 6 | ; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) 7 | ; which can be found in the file epl-v10.html at the root of this distribution. 8 | ; By using this software in any fashion, you are agreeing to be bound by 9 | ; the terms of this license. 10 | ; You must not remove this notice, or any other, from this software. 11 | 12 | ;; Author: Tom Faulhaber 13 | ;; April 3, 2009 14 | ;; Revised to use proxy instead of gen-class April 2010 15 | 16 | ;; This module implements a column-aware wrapper around an instance of java.io.Writer 17 | 18 | (in-ns 'clojure.pprint) 19 | 20 | (import [clojure.lang IDeref] 21 | [java.io Writer]) 22 | 23 | (def ^:dynamic ^{:private true} *default-page-width* 72) 24 | 25 | (defn- get-field [^Writer this sym] 26 | (sym @@this)) 27 | 28 | (defn- set-field [^Writer this sym new-val] 29 | (alter @this assoc sym new-val)) 30 | 31 | (defn- get-column [this] 32 | (get-field this :cur)) 33 | 34 | (defn- get-line [this] 35 | (get-field this :line)) 36 | 37 | (defn- get-max-column [this] 38 | (get-field this :max)) 39 | 40 | (defn- set-max-column [this new-max] 41 | (dosync (set-field this :max new-max)) 42 | nil) 43 | 44 | (defn- get-writer [this] 45 | (get-field this :base)) 46 | 47 | (defn- c-write-char [^Writer this ^Integer c] 48 | (dosync (if (= c (int \newline)) 49 | (do 50 | (set-field this :cur 0) 51 | (set-field this :line (inc (get-field this :line)))) 52 | (set-field this :cur (inc (get-field this :cur))))) 53 | (.write ^Writer (get-field this :base) c)) 54 | 55 | (defn- column-writer 56 | ([writer] (column-writer writer *default-page-width*)) 57 | ([writer max-columns] 58 | (let [fields (ref {:max max-columns, :cur 0, :line 0 :base writer})] 59 | (proxy [Writer IDeref] [] 60 | (deref [] fields) 61 | (flush [] 62 | (.flush writer)) 63 | (write 64 | ([^chars cbuf ^Integer off ^Integer len] 65 | (let [^Writer writer (get-field this :base)] 66 | (.write writer cbuf off len))) 67 | ([x] 68 | (condp = (class x) 69 | String 70 | (let [^String s x 71 | nl (.lastIndexOf s (int \newline))] 72 | (dosync (if (neg? nl) 73 | (set-field this :cur (+ (get-field this :cur) (count s))) 74 | (do 75 | (set-field this :cur (- (count s) nl 1)) 76 | (set-field this :line (+ (get-field this :line) 77 | (count (filter #(= % \newline) s))))))) 78 | (.write ^Writer (get-field this :base) s)) 79 | 80 | Integer 81 | (c-write-char this x) 82 | Long 83 | (c-write-char this x)))))))) 84 | -------------------------------------------------------------------------------- /src/clj/pprint/dispatch.clj: -------------------------------------------------------------------------------- 1 | ;; dispatch.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 | 15 | ;; This module implements the default dispatch tables for pretty printing code and 16 | ;; data. 17 | 18 | (in-ns 'clojure.pprint) 19 | 20 | (defn- use-method 21 | "Installs a function as a new method of multimethod associated with dispatch-value. " 22 | [multifn dispatch-val func] 23 | (. multifn addMethod dispatch-val func)) 24 | 25 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 26 | ;; Implementations of specific dispatch table entries 27 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 28 | 29 | ;;; Handle forms that can be "back-translated" to reader macros 30 | ;;; Not all reader macros can be dealt with this way or at all. 31 | ;;; Macros that we can't deal with at all are: 32 | ;;; ; - The comment character is absorbed by the reader and never is part of the form 33 | ;;; ` - Is fully processed at read time into a lisp expression (which will contain concats 34 | ;;; and regular quotes). 35 | ;;; ~@ - Also fully eaten by the processing of ` and can't be used outside. 36 | ;;; , - is whitespace and is lost (like all other whitespace). Formats can generate commas 37 | ;;; where they deem them useful to help readability. 38 | ;;; ^ - Adding metadata completely disappears at read time and the data appears to be 39 | ;;; completely lost. 40 | ;;; 41 | ;;; Most other syntax stuff is dealt with directly by the formats (like (), [], {}, and #{}) 42 | ;;; or directly by printing the objects using Clojure's built-in print functions (like 43 | ;;; :keyword, \char, or ""). The notable exception is #() which is special-cased. 44 | 45 | (def ^{:private true} reader-macros 46 | {'quote "'", 'clojure.core/deref "@", 47 | 'var "#'", 'clojure.core/unquote "~"}) 48 | 49 | (defn- pprint-reader-macro [alis] 50 | (let [^String macro-char (reader-macros (first alis))] 51 | (when (and macro-char (= 2 (count alis))) 52 | (.write ^java.io.Writer *out* macro-char) 53 | (write-out (second alis)) 54 | true))) 55 | 56 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 57 | ;; Dispatch for the basic data types when interpreted 58 | ;; as data (as opposed to code). 59 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 60 | 61 | ;;; TODO: inline these formatter statements into funcs so that we 62 | ;;; are a little easier on the stack. (Or, do "real" compilation, a 63 | ;;; la Common Lisp) 64 | 65 | ;;; (def pprint-simple-list (formatter-out "~:<~@{~w~^ ~_~}~:>")) 66 | (defn- pprint-simple-list [alis] 67 | (pprint-logical-block :prefix "(" :suffix ")" 68 | (print-length-loop [alis (seq alis)] 69 | (when alis 70 | (write-out (first alis)) 71 | (when (next alis) 72 | (.write ^java.io.Writer *out* " ") 73 | (pprint-newline :linear) 74 | (recur (next alis))))))) 75 | 76 | (defn- pprint-list [alis] 77 | (if-not (pprint-reader-macro alis) 78 | (pprint-simple-list alis))) 79 | 80 | ;;; (def pprint-vector (formatter-out "~<[~;~@{~w~^ ~_~}~;]~:>")) 81 | (defn- pprint-vector [avec] 82 | (pprint-logical-block :prefix "[" :suffix "]" 83 | (print-length-loop [aseq (seq avec)] 84 | (when aseq 85 | (write-out (first aseq)) 86 | (when (next aseq) 87 | (.write ^java.io.Writer *out* " ") 88 | (pprint-newline :linear) 89 | (recur (next aseq))))))) 90 | 91 | (def ^{:private true} pprint-array (formatter-out "~<[~;~@{~w~^, ~:_~}~;]~:>")) 92 | 93 | ;;; (def pprint-map (formatter-out "~<{~;~@{~<~w~^ ~_~w~:>~^, ~_~}~;}~:>")) 94 | (defn- pprint-map [amap] 95 | (pprint-logical-block :prefix "{" :suffix "}" 96 | (print-length-loop [aseq (seq amap)] 97 | (when aseq 98 | (pprint-logical-block 99 | (write-out (ffirst aseq)) 100 | (.write ^java.io.Writer *out* " ") 101 | (pprint-newline :linear) 102 | (set! *current-length* 0) ; always print both parts of the [k v] pair 103 | (write-out (fnext (first aseq)))) 104 | (when (next aseq) 105 | (.write ^java.io.Writer *out* ", ") 106 | (pprint-newline :linear) 107 | (recur (next aseq))))))) 108 | 109 | (def ^{:private true} pprint-set (formatter-out "~<#{~;~@{~w~^ ~:_~}~;}~:>")) 110 | 111 | (def ^{:private true} 112 | type-map {"core$future_call" "Future", 113 | "core$promise" "Promise"}) 114 | 115 | (defn- map-ref-type 116 | "Map ugly type names to something simpler" 117 | [name] 118 | (or (when-let [match (re-find #"^[^$]+\$[^$]+" name)] 119 | (type-map match)) 120 | name)) 121 | 122 | (defn- pprint-ideref [o] 123 | (let [prefix (format "#<%s@%x%s: " 124 | (map-ref-type (.getSimpleName (class o))) 125 | (System/identityHashCode o) 126 | (if (and (instance? clojure.lang.Agent o) 127 | (agent-error o)) 128 | " FAILED" 129 | ""))] 130 | (pprint-logical-block :prefix prefix :suffix ">" 131 | (pprint-indent :block (-> (count prefix) (- 2) -)) 132 | (pprint-newline :linear) 133 | (write-out (cond 134 | (and (future? o) (not (future-done? o))) :pending 135 | (and (instance? clojure.lang.IPending o) (not (.isRealized o))) :not-delivered 136 | :else @o))))) 137 | 138 | (def ^{:private true} pprint-pqueue (formatter-out "~<<-(~;~@{~w~^ ~_~}~;)-<~:>")) 139 | 140 | (defn- pprint-simple-default [obj] 141 | (cond 142 | (.isArray (class obj)) (pprint-array obj) 143 | (and *print-suppress-namespaces* (symbol? obj)) (print (name obj)) 144 | :else (pr obj))) 145 | 146 | 147 | (defmulti 148 | simple-dispatch 149 | "The pretty print dispatch function for simple data structure format." 150 | {:added "1.2" :arglists '[[object]]} 151 | class) 152 | 153 | (use-method simple-dispatch clojure.lang.ISeq pprint-list) 154 | (use-method simple-dispatch clojure.lang.IPersistentVector pprint-vector) 155 | (use-method simple-dispatch clojure.lang.IPersistentMap pprint-map) 156 | (use-method simple-dispatch clojure.lang.IPersistentSet pprint-set) 157 | (use-method simple-dispatch clojure.lang.PersistentQueue pprint-pqueue) 158 | (use-method simple-dispatch clojure.lang.IDeref pprint-ideref) 159 | (use-method simple-dispatch nil pr) 160 | (use-method simple-dispatch :default pprint-simple-default) 161 | 162 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 163 | ;;; Dispatch for the code table 164 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 165 | 166 | (declare pprint-simple-code-list) 167 | 168 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 169 | ;;; Format the namespace ("ns") macro. This is quite complicated because of all the 170 | ;;; different forms supported and because programmers can choose lists or vectors 171 | ;;; in various places. 172 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 173 | 174 | (defn- brackets 175 | "Figure out which kind of brackets to use" 176 | [form] 177 | (if (vector? form) 178 | ["[" "]"] 179 | ["(" ")"])) 180 | 181 | (defn- pprint-ns-reference 182 | "Pretty print a single reference (import, use, etc.) from a namespace decl" 183 | [reference] 184 | (if (sequential? reference) 185 | (let [[start end] (brackets reference) 186 | [keyw & args] reference] 187 | (pprint-logical-block :prefix start :suffix end 188 | ((formatter-out "~w~:i") keyw) 189 | (loop [args args] 190 | (when (seq args) 191 | ((formatter-out " ")) 192 | (let [arg (first args)] 193 | (if (sequential? arg) 194 | (let [[start end] (brackets arg)] 195 | (pprint-logical-block :prefix start :suffix end 196 | (if (and (= (count arg) 3) (keyword? (second arg))) 197 | (let [[ns kw lis] arg] 198 | ((formatter-out "~w ~w ") ns kw) 199 | (if (sequential? lis) 200 | ((formatter-out (if (vector? lis) 201 | "~<[~;~@{~w~^ ~:_~}~;]~:>" 202 | "~<(~;~@{~w~^ ~:_~}~;)~:>")) 203 | lis) 204 | (write-out lis))) 205 | (apply (formatter-out "~w ~:i~@{~w~^ ~:_~}") arg))) 206 | (when (next args) 207 | ((formatter-out "~_")))) 208 | (do 209 | (write-out arg) 210 | (when (next args) 211 | ((formatter-out "~:_")))))) 212 | (recur (next args)))))) 213 | (write-out reference))) 214 | 215 | (defn- pprint-ns 216 | "The pretty print dispatch chunk for the ns macro" 217 | [alis] 218 | (if (next alis) 219 | (let [[ns-sym ns-name & stuff] alis 220 | [doc-str stuff] (if (string? (first stuff)) 221 | [(first stuff) (next stuff)] 222 | [nil stuff]) 223 | [attr-map references] (if (map? (first stuff)) 224 | [(first stuff) (next stuff)] 225 | [nil stuff])] 226 | (pprint-logical-block :prefix "(" :suffix ")" 227 | ((formatter-out "~w ~1I~@_~w") ns-sym ns-name) 228 | (when (or doc-str attr-map (seq references)) 229 | ((formatter-out "~@:_"))) 230 | (when doc-str 231 | (cl-format true "\"~a\"~:[~;~:@_~]" doc-str (or attr-map (seq references)))) 232 | (when attr-map 233 | ((formatter-out "~w~:[~;~:@_~]") attr-map (seq references))) 234 | (loop [references references] 235 | (pprint-ns-reference (first references)) 236 | (when-let [references (next references)] 237 | (pprint-newline :linear) 238 | (recur references))))) 239 | (write-out alis))) 240 | 241 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 242 | ;;; Format something that looks like a simple def (sans metadata, since the reader 243 | ;;; won't give it to us now). 244 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 245 | 246 | (def ^{:private true} pprint-hold-first (formatter-out "~:<~w~^ ~@_~w~^ ~_~@{~w~^ ~_~}~:>")) 247 | 248 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 249 | ;;; Format something that looks like a defn or defmacro 250 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 251 | 252 | ;;; Format the params and body of a defn with a single arity 253 | (defn- single-defn [alis has-doc-str?] 254 | (if (seq alis) 255 | (do 256 | (if has-doc-str? 257 | ((formatter-out " ~_")) 258 | ((formatter-out " ~@_"))) 259 | ((formatter-out "~{~w~^ ~_~}") alis)))) 260 | 261 | ;;; Format the param and body sublists of a defn with multiple arities 262 | (defn- multi-defn [alis has-doc-str?] 263 | (if (seq alis) 264 | ((formatter-out " ~_~{~w~^ ~_~}") alis))) 265 | 266 | ;;; TODO: figure out how to support capturing metadata in defns (we might need a 267 | ;;; special reader) 268 | (defn- pprint-defn [alis] 269 | (if (next alis) 270 | (let [[defn-sym defn-name & stuff] alis 271 | [doc-str stuff] (if (string? (first stuff)) 272 | [(first stuff) (next stuff)] 273 | [nil stuff]) 274 | [attr-map stuff] (if (map? (first stuff)) 275 | [(first stuff) (next stuff)] 276 | [nil stuff])] 277 | (pprint-logical-block :prefix "(" :suffix ")" 278 | ((formatter-out "~w ~1I~@_~w") defn-sym defn-name) 279 | (if doc-str 280 | ((formatter-out " ~_~w") doc-str)) 281 | (if attr-map 282 | ((formatter-out " ~_~w") attr-map)) 283 | ;; Note: the multi-defn case will work OK for malformed defns too 284 | (cond 285 | (vector? (first stuff)) (single-defn stuff (or doc-str attr-map)) 286 | :else (multi-defn stuff (or doc-str attr-map))))) 287 | (pprint-simple-code-list alis))) 288 | 289 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 290 | ;;; Format something with a binding form 291 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 292 | 293 | (defn- pprint-binding-form [binding-vec] 294 | (pprint-logical-block :prefix "[" :suffix "]" 295 | (print-length-loop [binding binding-vec] 296 | (when (seq binding) 297 | (pprint-logical-block binding 298 | (write-out (first binding)) 299 | (when (next binding) 300 | (.write ^java.io.Writer *out* " ") 301 | (pprint-newline :miser) 302 | (write-out (second binding)))) 303 | (when (next (rest binding)) 304 | (.write ^java.io.Writer *out* " ") 305 | (pprint-newline :linear) 306 | (recur (next (rest binding)))))))) 307 | 308 | (defn- pprint-let [alis] 309 | (let [base-sym (first alis)] 310 | (pprint-logical-block :prefix "(" :suffix ")" 311 | (if (and (next alis) (vector? (second alis))) 312 | (do 313 | ((formatter-out "~w ~1I~@_") base-sym) 314 | (pprint-binding-form (second alis)) 315 | ((formatter-out " ~_~{~w~^ ~_~}") (next (rest alis)))) 316 | (pprint-simple-code-list alis))))) 317 | 318 | 319 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 320 | ;;; Format something that looks like "if" 321 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 322 | 323 | (def ^{:private true} pprint-if (formatter-out "~:<~1I~w~^ ~@_~w~@{ ~_~w~}~:>")) 324 | 325 | (defn- pprint-cond [alis] 326 | (pprint-logical-block :prefix "(" :suffix ")" 327 | (pprint-indent :block 1) 328 | (write-out (first alis)) 329 | (when (next alis) 330 | (.write ^java.io.Writer *out* " ") 331 | (pprint-newline :linear) 332 | (print-length-loop [alis (next alis)] 333 | (when alis 334 | (pprint-logical-block alis 335 | (write-out (first alis)) 336 | (when (next alis) 337 | (.write ^java.io.Writer *out* " ") 338 | (pprint-newline :miser) 339 | (write-out (second alis)))) 340 | (when (next (rest alis)) 341 | (.write ^java.io.Writer *out* " ") 342 | (pprint-newline :linear) 343 | (recur (next (rest alis))))))))) 344 | 345 | (defn- pprint-condp [alis] 346 | (if (> (count alis) 3) 347 | (pprint-logical-block :prefix "(" :suffix ")" 348 | (pprint-indent :block 1) 349 | (apply (formatter-out "~w ~@_~w ~@_~w ~_") alis) 350 | (print-length-loop [alis (seq (drop 3 alis))] 351 | (when alis 352 | (pprint-logical-block alis 353 | (write-out (first alis)) 354 | (when (next alis) 355 | (.write ^java.io.Writer *out* " ") 356 | (pprint-newline :miser) 357 | (write-out (second alis)))) 358 | (when (next (rest alis)) 359 | (.write ^java.io.Writer *out* " ") 360 | (pprint-newline :linear) 361 | (recur (next (rest alis))))))) 362 | (pprint-simple-code-list alis))) 363 | 364 | ;;; The map of symbols that are defined in an enclosing #() anonymous function 365 | (def ^:dynamic ^{:private true} *symbol-map* {}) 366 | 367 | (defn- pprint-anon-func [alis] 368 | (let [args (second alis) 369 | nlis (first (rest (rest alis)))] 370 | (if (vector? args) 371 | (binding [*symbol-map* (if (= 1 (count args)) 372 | {(first args) "%"} 373 | (into {} 374 | (map 375 | #(vector %1 (str \% %2)) 376 | args 377 | (range 1 (inc (count args))))))] 378 | ((formatter-out "~<#(~;~@{~w~^ ~_~}~;)~:>") nlis)) 379 | (pprint-simple-code-list alis)))) 380 | 381 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 382 | ;;; The master definitions for formatting lists in code (that is, (fn args...) or 383 | ;;; special forms). 384 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 385 | 386 | ;;; This is the equivalent of (formatter-out "~:<~1I~@{~w~^ ~_~}~:>"), but is 387 | ;;; easier on the stack. 388 | 389 | (defn- pprint-simple-code-list [alis] 390 | (pprint-logical-block :prefix "(" :suffix ")" 391 | (pprint-indent :block 1) 392 | (print-length-loop [alis (seq alis)] 393 | (when alis 394 | (write-out (first alis)) 395 | (when (next alis) 396 | (.write ^java.io.Writer *out* " ") 397 | (pprint-newline :linear) 398 | (recur (next alis))))))) 399 | 400 | ;;; Take a map with symbols as keys and add versions with no namespace. 401 | ;;; That is, if ns/sym->val is in the map, add sym->val to the result. 402 | (defn- two-forms [amap] 403 | (into {} 404 | (mapcat 405 | identity 406 | (for [x amap] 407 | [x [(symbol (name (first x))) (second x)]])))) 408 | 409 | (defn- add-core-ns [amap] 410 | (let [core "clojure.core"] 411 | (into {} 412 | (map #(let [[s f] %] 413 | (if (not (or (namespace s) (special-symbol? s))) 414 | [(symbol core (name s)) f] 415 | %)) 416 | amap)))) 417 | 418 | (def ^:dynamic ^{:private true} *code-table* 419 | (two-forms 420 | (add-core-ns 421 | {'def pprint-hold-first, 'defonce pprint-hold-first, 422 | 'defn pprint-defn, 'defn- pprint-defn, 'defmacro pprint-defn, 'fn pprint-defn, 423 | 'let pprint-let, 'loop pprint-let, 'binding pprint-let, 424 | 'with-local-vars pprint-let, 'with-open pprint-let, 'when-let pprint-let, 425 | 'if-let pprint-let, 'doseq pprint-let, 'dotimes pprint-let, 426 | 'when-first pprint-let, 427 | 'if pprint-if, 'if-not pprint-if, 'when pprint-if, 'when-not pprint-if, 428 | 'cond pprint-cond, 'condp pprint-condp, 429 | 'fn* pprint-anon-func, 430 | '. pprint-hold-first, '.. pprint-hold-first, '-> pprint-hold-first, 431 | 'locking pprint-hold-first, 'struct pprint-hold-first, 432 | 'struct-map pprint-hold-first, 'ns pprint-ns 433 | }))) 434 | 435 | (defn- pprint-code-list [alis] 436 | (if-not (pprint-reader-macro alis) 437 | (if-let [special-form (*code-table* (first alis))] 438 | (special-form alis) 439 | (pprint-simple-code-list alis)))) 440 | 441 | (defn- pprint-code-symbol [sym] 442 | (if-let [arg-num (sym *symbol-map*)] 443 | (print arg-num) 444 | (if *print-suppress-namespaces* 445 | (print (name sym)) 446 | (pr sym)))) 447 | 448 | (defmulti 449 | code-dispatch 450 | "The pretty print dispatch function for pretty printing Clojure code." 451 | {:added "1.2" :arglists '[[object]]} 452 | class) 453 | 454 | (use-method code-dispatch clojure.lang.ISeq pprint-code-list) 455 | (use-method code-dispatch clojure.lang.Symbol pprint-code-symbol) 456 | 457 | ;; The following are all exact copies of simple-dispatch 458 | (use-method code-dispatch clojure.lang.IPersistentVector pprint-vector) 459 | (use-method code-dispatch clojure.lang.IPersistentMap pprint-map) 460 | (use-method code-dispatch clojure.lang.IPersistentSet pprint-set) 461 | (use-method code-dispatch clojure.lang.PersistentQueue pprint-pqueue) 462 | (use-method code-dispatch clojure.lang.IDeref pprint-ideref) 463 | (use-method code-dispatch nil pr) 464 | (use-method code-dispatch :default pprint-simple-default) 465 | 466 | (set-pprint-dispatch simple-dispatch) 467 | 468 | 469 | ;;; For testing 470 | (comment 471 | 472 | (with-pprint-dispatch code-dispatch 473 | (pprint 474 | '(defn cl-format 475 | "An implementation of a Common Lisp compatible format function" 476 | [stream format-in & args] 477 | (let [compiled-format (if (string? format-in) (compile-format format-in) format-in) 478 | navigator (init-navigator args)] 479 | (execute-format stream compiled-format navigator))))) 480 | 481 | (with-pprint-dispatch code-dispatch 482 | (pprint 483 | '(defn cl-format 484 | [stream format-in & args] 485 | (let [compiled-format (if (string? format-in) (compile-format format-in) format-in) 486 | navigator (init-navigator args)] 487 | (execute-format stream compiled-format navigator))))) 488 | 489 | (with-pprint-dispatch code-dispatch 490 | (pprint 491 | '(defn- -write 492 | ([this x] 493 | (condp = (class x) 494 | String 495 | (let [s0 (write-initial-lines this x) 496 | s (.replaceFirst s0 "\\s+$" "") 497 | white-space (.substring s0 (count s)) 498 | mode (getf :mode)] 499 | (if (= mode :writing) 500 | (dosync 501 | (write-white-space this) 502 | (.col_write this s) 503 | (setf :trailing-white-space white-space)) 504 | (add-to-buffer this (make-buffer-blob s white-space)))) 505 | 506 | Integer 507 | (let [c ^Character x] 508 | (if (= (getf :mode) :writing) 509 | (do 510 | (write-white-space this) 511 | (.col_write this x)) 512 | (if (= c (int \newline)) 513 | (write-initial-lines this "\n") 514 | (add-to-buffer this (make-buffer-blob (str (char c)) nil)))))))))) 515 | 516 | (with-pprint-dispatch code-dispatch 517 | (pprint 518 | '(defn pprint-defn [writer alis] 519 | (if (next alis) 520 | (let [[defn-sym defn-name & stuff] alis 521 | [doc-str stuff] (if (string? (first stuff)) 522 | [(first stuff) (next stuff)] 523 | [nil stuff]) 524 | [attr-map stuff] (if (map? (first stuff)) 525 | [(first stuff) (next stuff)] 526 | [nil stuff])] 527 | (pprint-logical-block writer :prefix "(" :suffix ")" 528 | (cl-format true "~w ~1I~@_~w" defn-sym defn-name) 529 | (if doc-str 530 | (cl-format true " ~_~w" doc-str)) 531 | (if attr-map 532 | (cl-format true " ~_~w" attr-map)) 533 | ;; Note: the multi-defn case will work OK for malformed defns too 534 | (cond 535 | (vector? (first stuff)) (single-defn stuff (or doc-str attr-map)) 536 | :else (multi-defn stuff (or doc-str attr-map))))) 537 | (pprint-simple-code-list writer alis))))) 538 | ) 539 | nil 540 | 541 | -------------------------------------------------------------------------------- /src/clj/pprint/pprint_base.clj: -------------------------------------------------------------------------------- 1 | ;;; pprint_base.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 | 15 | ;; This module implements the generic pretty print functions and special variables 16 | 17 | (in-ns 'clojure.pprint) 18 | 19 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 20 | ;; Variables that control the pretty printer 21 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 22 | 23 | ;;; 24 | ;;; *print-length*, *print-level* and *print-dup* are defined in clojure.core 25 | ;;; TODO: use *print-dup* here (or is it supplanted by other variables?) 26 | ;;; TODO: make dispatch items like "(let..." get counted in *print-length* 27 | ;;; constructs 28 | 29 | 30 | (def ^:dynamic 31 | ^{:doc "Bind to true if you want write to use pretty printing", :added "1.2"} 32 | *print-pretty* true) 33 | 34 | (defonce ^:dynamic ; If folks have added stuff here, don't overwrite 35 | ^{:doc "The pretty print dispatch function. Use with-pprint-dispatch or set-pprint-dispatch 36 | to modify.", 37 | :added "1.2"} 38 | *print-pprint-dispatch* nil) 39 | 40 | (def ^:dynamic 41 | ^{:doc "Pretty printing will try to avoid anything going beyond this column. 42 | Set it to nil to have pprint let the line be arbitrarily long. This will ignore all 43 | non-mandatory newlines.", 44 | :added "1.2"} 45 | *print-right-margin* 72) 46 | 47 | (def ^:dynamic 48 | ^{:doc "The column at which to enter miser style. Depending on the dispatch table, 49 | miser style add newlines in more places to try to keep lines short allowing for further 50 | levels of nesting.", 51 | :added "1.2"} 52 | *print-miser-width* 40) 53 | 54 | ;;; TODO implement output limiting 55 | (def ^:dynamic 56 | ^{:private true, 57 | :doc "Maximum number of lines to print in a pretty print instance (N.B. This is not yet used)"} 58 | *print-lines* nil) 59 | 60 | ;;; TODO: implement circle and shared 61 | (def ^:dynamic 62 | ^{:private true, 63 | :doc "Mark circular structures (N.B. This is not yet used)"} 64 | *print-circle* nil) 65 | 66 | ;;; TODO: should we just use *print-dup* here? 67 | (def ^:dynamic 68 | ^{:private true, 69 | :doc "Mark repeated structures rather than repeat them (N.B. This is not yet used)"} 70 | *print-shared* nil) 71 | 72 | (def ^:dynamic 73 | ^{:doc "Don't print namespaces with symbols. This is particularly useful when 74 | pretty printing the results of macro expansions" 75 | :added "1.2"} 76 | *print-suppress-namespaces* nil) 77 | 78 | ;;; TODO: support print-base and print-radix in cl-format 79 | ;;; TODO: support print-base and print-radix in rationals 80 | (def ^:dynamic 81 | ^{:doc "Print a radix specifier in front of integers and rationals. If *print-base* is 2, 8, 82 | or 16, then the radix specifier used is #b, #o, or #x, respectively. Otherwise the 83 | radix specifier is in the form #XXr where XX is the decimal value of *print-base* " 84 | :added "1.2"} 85 | *print-radix* nil) 86 | 87 | (def ^:dynamic 88 | ^{:doc "The base to use for printing integers and rationals." 89 | :added "1.2"} 90 | *print-base* 10) 91 | 92 | 93 | 94 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 95 | ;; Internal variables that keep track of where we are in the 96 | ;; structure 97 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 98 | 99 | (def ^:dynamic ^{ :private true } *current-level* 0) 100 | 101 | (def ^:dynamic ^{ :private true } *current-length* nil) 102 | 103 | ;; TODO: add variables for length, lines. 104 | 105 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 106 | ;; Support for the write function 107 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 108 | 109 | (declare format-simple-number) 110 | 111 | (def ^{:private true} orig-pr pr) 112 | 113 | (defn- pr-with-base [x] 114 | (if-let [s (format-simple-number x)] 115 | (print s) 116 | (orig-pr x))) 117 | 118 | (def ^{:private true} write-option-table 119 | {;:array *print-array* 120 | :base 'clojure.pprint/*print-base*, 121 | ;;:case *print-case*, 122 | :circle 'clojure.pprint/*print-circle*, 123 | ;;:escape *print-escape*, 124 | ;;:gensym *print-gensym*, 125 | :length 'clojure.core/*print-length*, 126 | :level 'clojure.core/*print-level*, 127 | :lines 'clojure.pprint/*print-lines*, 128 | :miser-width 'clojure.pprint/*print-miser-width*, 129 | :dispatch 'clojure.pprint/*print-pprint-dispatch*, 130 | :pretty 'clojure.pprint/*print-pretty*, 131 | :radix 'clojure.pprint/*print-radix*, 132 | :readably 'clojure.core/*print-readably*, 133 | :right-margin 'clojure.pprint/*print-right-margin*, 134 | :suppress-namespaces 'clojure.pprint/*print-suppress-namespaces*}) 135 | 136 | 137 | (defmacro ^{:private true} binding-map [amap & body] 138 | (let [] 139 | `(do 140 | (. clojure.lang.Var (pushThreadBindings ~amap)) 141 | (try 142 | ~@body 143 | (finally 144 | (. clojure.lang.Var (popThreadBindings))))))) 145 | 146 | (defn- table-ize [t m] 147 | (apply hash-map (mapcat 148 | #(when-let [v (get t (key %))] [(find-var v) (val %)]) 149 | m))) 150 | 151 | (defn- pretty-writer? 152 | "Return true iff x is a PrettyWriter" 153 | [x] (and (instance? clojure.lang.IDeref x) (:pretty-writer @@x))) 154 | 155 | (defn- make-pretty-writer 156 | "Wrap base-writer in a PrettyWriter with the specified right-margin and miser-width" 157 | [base-writer right-margin miser-width] 158 | (pretty-writer base-writer right-margin miser-width)) 159 | 160 | (defmacro ^{:private true} with-pretty-writer [base-writer & body] 161 | `(let [base-writer# ~base-writer 162 | new-writer# (not (pretty-writer? base-writer#))] 163 | (binding [*out* (if new-writer# 164 | (make-pretty-writer base-writer# *print-right-margin* *print-miser-width*) 165 | base-writer#)] 166 | ~@body 167 | (.ppflush *out*)))) 168 | 169 | 170 | ;;;TODO: if pretty print is not set, don't use pr but rather something that respects *print-base*, etc. 171 | (defn write-out 172 | "Write an object to *out* subject to the current bindings of the printer control 173 | variables. Use the kw-args argument to override individual variables for this call (and 174 | any recursive calls). 175 | 176 | *out* must be a PrettyWriter if pretty printing is enabled. This is the responsibility 177 | of the caller. 178 | 179 | This method is primarily intended for use by pretty print dispatch functions that 180 | already know that the pretty printer will have set up their environment appropriately. 181 | Normal library clients should use the standard \"write\" interface. " 182 | {:added "1.2"} 183 | [object] 184 | (let [length-reached (and 185 | *current-length* 186 | *print-length* 187 | (>= *current-length* *print-length*))] 188 | (if-not *print-pretty* 189 | (pr object) 190 | (if length-reached 191 | (print "...") 192 | (do 193 | (if *current-length* (set! *current-length* (inc *current-length*))) 194 | (*print-pprint-dispatch* object)))) 195 | length-reached)) 196 | 197 | (defn write 198 | "Write an object subject to the current bindings of the printer control variables. 199 | Use the kw-args argument to override individual variables for this call (and any 200 | recursive calls). Returns the string result if :stream is nil or nil otherwise. 201 | 202 | The following keyword arguments can be passed with values: 203 | Keyword Meaning Default value 204 | :stream Writer for output or nil true (indicates *out*) 205 | :base Base to use for writing rationals Current value of *print-base* 206 | :circle* If true, mark circular structures Current value of *print-circle* 207 | :length Maximum elements to show in sublists Current value of *print-length* 208 | :level Maximum depth Current value of *print-level* 209 | :lines* Maximum lines of output Current value of *print-lines* 210 | :miser-width Width to enter miser mode Current value of *print-miser-width* 211 | :dispatch The pretty print dispatch function Current value of *print-pprint-dispatch* 212 | :pretty If true, do pretty printing Current value of *print-pretty* 213 | :radix If true, prepend a radix specifier Current value of *print-radix* 214 | :readably* If true, print readably Current value of *print-readably* 215 | :right-margin The column for the right margin Current value of *print-right-margin* 216 | :suppress-namespaces If true, no namespaces in symbols Current value of *print-suppress-namespaces* 217 | 218 | * = not yet supported 219 | " 220 | {:added "1.2"} 221 | [object & kw-args] 222 | (let [options (merge {:stream true} (apply hash-map kw-args))] 223 | (binding-map (table-ize write-option-table options) 224 | (binding-map (if (or (not (= *print-base* 10)) *print-radix*) {#'pr pr-with-base} {}) 225 | (let [optval (if (contains? options :stream) 226 | (:stream options) 227 | true) 228 | base-writer (condp = optval 229 | nil (java.io.StringWriter.) 230 | true *out* 231 | optval)] 232 | (if *print-pretty* 233 | (with-pretty-writer base-writer 234 | (write-out object)) 235 | (binding [*out* base-writer] 236 | (pr object))) 237 | (if (nil? optval) 238 | (.toString ^java.io.StringWriter base-writer))))))) 239 | 240 | 241 | (defn pprint 242 | "Pretty print object to the optional output writer. If the writer is not provided, 243 | print the object to the currently bound value of *out*." 244 | {:added "1.2"} 245 | ([object] (pprint object *out*)) 246 | ([object writer] 247 | (with-pretty-writer writer 248 | (binding [*print-pretty* true] 249 | (binding-map (if (or (not (= *print-base* 10)) *print-radix*) {#'pr pr-with-base} {}) 250 | (write-out object))) 251 | (if (not (= 0 (get-column *out*))) 252 | (prn))))) 253 | 254 | (defmacro pp 255 | "A convenience macro that pretty prints the last thing output. This is 256 | exactly equivalent to (pprint *1)." 257 | {:added "1.2"} 258 | [] `(pprint *1)) 259 | 260 | (defn set-pprint-dispatch 261 | "Set the pretty print dispatch function to a function matching (fn [obj] ...) 262 | where obj is the object to pretty print. That function will be called with *out* set 263 | to a pretty printing writer to which it should do its printing. 264 | 265 | For example functions, see simple-dispatch and code-dispatch in 266 | clojure.pprint.dispatch.clj." 267 | {:added "1.2"} 268 | [function] 269 | (let [old-meta (meta #'*print-pprint-dispatch*)] 270 | (alter-var-root #'*print-pprint-dispatch* (constantly function)) 271 | (alter-meta! #'*print-pprint-dispatch* (constantly old-meta))) 272 | nil) 273 | 274 | (defmacro with-pprint-dispatch 275 | "Execute body with the pretty print dispatch function bound to function." 276 | {:added "1.2"} 277 | [function & body] 278 | `(binding [*print-pprint-dispatch* ~function] 279 | ~@body)) 280 | 281 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 282 | ;; Support for the functional interface to the pretty printer 283 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 284 | 285 | (defn- parse-lb-options [opts body] 286 | (loop [body body 287 | acc []] 288 | (if (opts (first body)) 289 | (recur (drop 2 body) (concat acc (take 2 body))) 290 | [(apply hash-map acc) body]))) 291 | 292 | (defn- check-enumerated-arg [arg choices] 293 | (if-not (choices arg) 294 | (throw 295 | (IllegalArgumentException. 296 | ;; TODO clean up choices string 297 | (str "Bad argument: " arg ". It must be one of " choices))))) 298 | 299 | (defn- level-exceeded [] 300 | (and *print-level* (>= *current-level* *print-level*))) 301 | 302 | (defmacro pprint-logical-block 303 | "Execute the body as a pretty printing logical block with output to *out* which 304 | must be a pretty printing writer. When used from pprint or cl-format, this can be 305 | assumed. 306 | 307 | This function is intended for use when writing custom dispatch functions. 308 | 309 | Before the body, the caller can optionally specify options: :prefix, :per-line-prefix, 310 | and :suffix." 311 | {:added "1.2", :arglists '[[options* body]]} 312 | [& args] 313 | (let [[options body] (parse-lb-options #{:prefix :per-line-prefix :suffix} args)] 314 | `(do (if (#'clojure.pprint/level-exceeded) 315 | (.write ^java.io.Writer *out* "#") 316 | (do 317 | (push-thread-bindings {#'clojure.pprint/*current-level* 318 | (inc (var-get #'clojure.pprint/*current-level*)) 319 | #'clojure.pprint/*current-length* 0}) 320 | (try 321 | (#'clojure.pprint/start-block *out* 322 | ~(:prefix options) ~(:per-line-prefix options) ~(:suffix options)) 323 | ~@body 324 | (#'clojure.pprint/end-block *out*) 325 | (finally 326 | (pop-thread-bindings))))) 327 | nil))) 328 | 329 | (defn pprint-newline 330 | "Print a conditional newline to a pretty printing stream. kind specifies if the 331 | newline is :linear, :miser, :fill, or :mandatory. 332 | 333 | This function is intended for use when writing custom dispatch functions. 334 | 335 | Output is sent to *out* which must be a pretty printing writer." 336 | {:added "1.2"} 337 | [kind] 338 | (check-enumerated-arg kind #{:linear :miser :fill :mandatory}) 339 | (nl *out* kind)) 340 | 341 | (defn pprint-indent 342 | "Create an indent at this point in the pretty printing stream. This defines how 343 | following lines are indented. relative-to can be either :block or :current depending 344 | whether the indent should be computed relative to the start of the logical block or 345 | the current column position. n is an offset. 346 | 347 | This function is intended for use when writing custom dispatch functions. 348 | 349 | Output is sent to *out* which must be a pretty printing writer." 350 | {:added "1.2"} 351 | [relative-to n] 352 | (check-enumerated-arg relative-to #{:block :current}) 353 | (indent *out* relative-to n)) 354 | 355 | ;; TODO a real implementation for pprint-tab 356 | (defn pprint-tab 357 | "Tab at this point in the pretty printing stream. kind specifies whether the tab 358 | is :line, :section, :line-relative, or :section-relative. 359 | 360 | Colnum and colinc specify the target column and the increment to move the target 361 | forward if the output is already past the original target. 362 | 363 | This function is intended for use when writing custom dispatch functions. 364 | 365 | Output is sent to *out* which must be a pretty printing writer. 366 | 367 | THIS FUNCTION IS NOT YET IMPLEMENTED." 368 | {:added "1.2"} 369 | [kind colnum colinc] 370 | (check-enumerated-arg kind #{:line :section :line-relative :section-relative}) 371 | (throw (UnsupportedOperationException. "pprint-tab is not yet implemented"))) 372 | 373 | 374 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 375 | ;;; 376 | ;;; Helpers for dispatch function writing 377 | ;;; 378 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 379 | 380 | (defn- pll-mod-body [var-sym body] 381 | (letfn [(inner [form] 382 | (if (seq? form) 383 | (let [form (macroexpand form)] 384 | (condp = (first form) 385 | 'loop* form 386 | 'recur (concat `(recur (inc ~var-sym)) (rest form)) 387 | (walk inner identity form))) 388 | form))] 389 | (walk inner identity body))) 390 | 391 | (defmacro print-length-loop 392 | "A version of loop that iterates at most *print-length* times. This is designed 393 | for use in pretty-printer dispatch functions." 394 | {:added "1.3"} 395 | [bindings & body] 396 | (let [count-var (gensym "length-count") 397 | mod-body (pll-mod-body count-var body)] 398 | `(loop ~(apply vector count-var 0 bindings) 399 | (if (or (not *print-length*) (< ~count-var *print-length*)) 400 | (do ~@mod-body) 401 | (.write ^java.io.Writer *out* "..."))))) 402 | 403 | nil 404 | -------------------------------------------------------------------------------- /src/clj/pprint/pretty_writer.clj: -------------------------------------------------------------------------------- 1 | ;;; pretty_writer.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 | ;; Revised to use proxy instead of gen-class April 2010 14 | 15 | ;; This module implements a wrapper around a java.io.Writer which implements the 16 | ;; core of the XP algorithm. 17 | 18 | (in-ns 'clojure.pprint) 19 | 20 | (import [clojure.lang IDeref] 21 | [java.io Writer]) 22 | 23 | ;; TODO: Support for tab directives 24 | 25 | 26 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 27 | ;;; Forward declarations 28 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 29 | 30 | (declare get-miser-width) 31 | 32 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 33 | ;;; Macros to simplify dealing with types and classes. These are 34 | ;;; really utilities, but I'm experimenting with them here. 35 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 36 | 37 | (defmacro ^{:private true} 38 | getf 39 | "Get the value of the field a named by the argument (which should be a keyword)." 40 | [sym] 41 | `(~sym @@~'this)) 42 | 43 | (defmacro ^{:private true} 44 | setf [sym new-val] 45 | "Set the value of the field SYM to NEW-VAL" 46 | `(alter @~'this assoc ~sym ~new-val)) 47 | 48 | (defmacro ^{:private true} 49 | deftype [type-name & fields] 50 | (let [name-str (name type-name)] 51 | `(do 52 | (defstruct ~type-name :type-tag ~@fields) 53 | (alter-meta! #'~type-name assoc :private true) 54 | (defn- ~(symbol (str "make-" name-str)) 55 | [& vals#] (apply struct ~type-name ~(keyword name-str) vals#)) 56 | (defn- ~(symbol (str name-str "?")) [x#] (= (:type-tag x#) ~(keyword name-str)))))) 57 | 58 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 59 | ;;; The data structures used by pretty-writer 60 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 61 | 62 | (defstruct ^{:private true} logical-block 63 | :parent :section :start-col :indent 64 | :done-nl :intra-block-nl 65 | :prefix :per-line-prefix :suffix 66 | :logical-block-callback) 67 | 68 | (defn- ancestor? [parent child] 69 | (loop [child (:parent child)] 70 | (cond 71 | (nil? child) false 72 | (identical? parent child) true 73 | :else (recur (:parent child))))) 74 | 75 | (defstruct ^{:private true} section :parent) 76 | 77 | (defn- buffer-length [l] 78 | (let [l (seq l)] 79 | (if l 80 | (- (:end-pos (last l)) (:start-pos (first l))) 81 | 0))) 82 | 83 | ; A blob of characters (aka a string) 84 | (deftype buffer-blob :data :trailing-white-space :start-pos :end-pos) 85 | 86 | ; A newline 87 | (deftype nl-t :type :logical-block :start-pos :end-pos) 88 | 89 | (deftype start-block-t :logical-block :start-pos :end-pos) 90 | 91 | (deftype end-block-t :logical-block :start-pos :end-pos) 92 | 93 | (deftype indent-t :logical-block :relative-to :offset :start-pos :end-pos) 94 | 95 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 96 | ;;; Functions to write tokens in the output buffer 97 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 98 | 99 | (def ^:private pp-newline (memoize #(System/getProperty "line.separator"))) 100 | 101 | (declare emit-nl) 102 | 103 | (defmulti ^{:private true} write-token #(:type-tag %2)) 104 | (defmethod write-token :start-block-t [^Writer this token] 105 | (when-let [cb (getf :logical-block-callback)] (cb :start)) 106 | (let [lb (:logical-block token)] 107 | (dosync 108 | (when-let [^String prefix (:prefix lb)] 109 | (.write (getf :base) prefix)) 110 | (let [col (get-column (getf :base))] 111 | (ref-set (:start-col lb) col) 112 | (ref-set (:indent lb) col))))) 113 | 114 | (defmethod write-token :end-block-t [^Writer this token] 115 | (when-let [cb (getf :logical-block-callback)] (cb :end)) 116 | (when-let [^String suffix (:suffix (:logical-block token))] 117 | (.write (getf :base) suffix))) 118 | 119 | (defmethod write-token :indent-t [^Writer this token] 120 | (let [lb (:logical-block token)] 121 | (ref-set (:indent lb) 122 | (+ (:offset token) 123 | (condp = (:relative-to token) 124 | :block @(:start-col lb) 125 | :current (get-column (getf :base))))))) 126 | 127 | (defmethod write-token :buffer-blob [^Writer this token] 128 | (.write (getf :base) ^String (:data token))) 129 | 130 | (defmethod write-token :nl-t [^Writer this token] 131 | ; (prlabel wt @(:done-nl (:logical-block token))) 132 | ; (prlabel wt (:type token) (= (:type token) :mandatory)) 133 | (if (or (= (:type token) :mandatory) 134 | (and (not (= (:type token) :fill)) 135 | @(:done-nl (:logical-block token)))) 136 | (emit-nl this token) 137 | (if-let [^String tws (getf :trailing-white-space)] 138 | (.write (getf :base) tws))) 139 | (dosync (setf :trailing-white-space nil))) 140 | 141 | (defn- write-tokens [^Writer this tokens force-trailing-whitespace] 142 | (doseq [token tokens] 143 | (if-not (= (:type-tag token) :nl-t) 144 | (if-let [^String tws (getf :trailing-white-space)] 145 | (.write (getf :base) tws))) 146 | (write-token this token) 147 | (setf :trailing-white-space (:trailing-white-space token))) 148 | (let [^String tws (getf :trailing-white-space)] 149 | (when (and force-trailing-whitespace tws) 150 | (.write (getf :base) tws) 151 | (setf :trailing-white-space nil)))) 152 | 153 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 154 | ;;; emit-nl? method defs for each type of new line. This makes 155 | ;;; the decision about whether to print this type of new line. 156 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 157 | 158 | 159 | (defn- tokens-fit? [^Writer this tokens] 160 | ;;; (prlabel tf? (get-column (getf :base) (buffer-length tokens)) 161 | (let [maxcol (get-max-column (getf :base))] 162 | (or 163 | (nil? maxcol) 164 | (< (+ (get-column (getf :base)) (buffer-length tokens)) maxcol)))) 165 | 166 | (defn- linear-nl? [this lb section] 167 | ; (prlabel lnl? @(:done-nl lb) (tokens-fit? this section)) 168 | (or @(:done-nl lb) 169 | (not (tokens-fit? this section)))) 170 | 171 | (defn- miser-nl? [^Writer this lb section] 172 | (let [miser-width (get-miser-width this) 173 | maxcol (get-max-column (getf :base))] 174 | (and miser-width maxcol 175 | (>= @(:start-col lb) (- maxcol miser-width)) 176 | (linear-nl? this lb section)))) 177 | 178 | (defmulti ^{:private true} emit-nl? (fn [t _ _ _] (:type t))) 179 | 180 | (defmethod emit-nl? :linear [newl this section _] 181 | (let [lb (:logical-block newl)] 182 | (linear-nl? this lb section))) 183 | 184 | (defmethod emit-nl? :miser [newl this section _] 185 | (let [lb (:logical-block newl)] 186 | (miser-nl? this lb section))) 187 | 188 | (defmethod emit-nl? :fill [newl this section subsection] 189 | (let [lb (:logical-block newl)] 190 | (or @(:intra-block-nl lb) 191 | (not (tokens-fit? this subsection)) 192 | (miser-nl? this lb section)))) 193 | 194 | (defmethod emit-nl? :mandatory [_ _ _ _] 195 | true) 196 | 197 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 198 | ;;; Various support functions 199 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 200 | 201 | 202 | (defn- get-section [buffer] 203 | (let [nl (first buffer) 204 | lb (:logical-block nl) 205 | section (seq (take-while #(not (and (nl-t? %) (ancestor? (:logical-block %) lb))) 206 | (next buffer)))] 207 | [section (seq (drop (inc (count section)) buffer))])) 208 | 209 | (defn- get-sub-section [buffer] 210 | (let [nl (first buffer) 211 | lb (:logical-block nl) 212 | section (seq (take-while #(let [nl-lb (:logical-block %)] 213 | (not (and (nl-t? %) (or (= nl-lb lb) (ancestor? nl-lb lb))))) 214 | (next buffer)))] 215 | section)) 216 | 217 | (defn- update-nl-state [lb] 218 | (dosync 219 | (ref-set (:intra-block-nl lb) false) 220 | (ref-set (:done-nl lb) true) 221 | (loop [lb (:parent lb)] 222 | (if lb 223 | (do (ref-set (:done-nl lb) true) 224 | (ref-set (:intra-block-nl lb) true) 225 | (recur (:parent lb))))))) 226 | 227 | (defn- emit-nl [^Writer this nl] 228 | (.write (getf :base) (pp-newline)) 229 | (dosync (setf :trailing-white-space nil)) 230 | (let [lb (:logical-block nl) 231 | ^String prefix (:per-line-prefix lb)] 232 | (if prefix 233 | (.write (getf :base) prefix)) 234 | (let [^String istr (apply str (repeat (- @(:indent lb) (count prefix)) 235 | \space))] 236 | (.write (getf :base) istr)) 237 | (update-nl-state lb))) 238 | 239 | (defn- split-at-newline [tokens] 240 | (let [pre (seq (take-while #(not (nl-t? %)) tokens))] 241 | [pre (seq (drop (count pre) tokens))])) 242 | 243 | ;;; Methods for showing token strings for debugging 244 | 245 | (defmulti ^{:private true} tok :type-tag) 246 | (defmethod tok :nl-t [token] 247 | (:type token)) 248 | (defmethod tok :buffer-blob [token] 249 | (str \" (:data token) (:trailing-white-space token) \")) 250 | (defmethod tok :default [token] 251 | (:type-tag token)) 252 | (defn- toks [toks] (map tok toks)) 253 | 254 | ;;; write-token-string is called when the set of tokens in the buffer 255 | ;;; is longer than the available space on the line 256 | 257 | (defn- write-token-string [this tokens] 258 | (let [[a b] (split-at-newline tokens)] 259 | ;; (prlabel wts (toks a) (toks b)) 260 | (if a (write-tokens this a false)) 261 | (if b 262 | (let [[section remainder] (get-section b) 263 | newl (first b)] 264 | ;; (prlabel wts (toks section)) (prlabel wts (:type newl)) (prlabel wts (toks remainder)) 265 | (let [do-nl (emit-nl? newl this section (get-sub-section b)) 266 | result (if do-nl 267 | (do 268 | ;; (prlabel emit-nl (:type newl)) 269 | (emit-nl this newl) 270 | (next b)) 271 | b) 272 | long-section (not (tokens-fit? this result)) 273 | result (if long-section 274 | (let [rem2 (write-token-string this section)] 275 | ;;; (prlabel recurse (toks rem2)) 276 | (if (= rem2 section) 277 | (do ; If that didn't produce any output, it has no nls 278 | ; so we'll force it 279 | (write-tokens this section false) 280 | remainder) 281 | (into [] (concat rem2 remainder)))) 282 | result) 283 | ;; ff (prlabel wts (toks result)) 284 | ] 285 | result))))) 286 | 287 | (defn- write-line [^Writer this] 288 | (dosync 289 | (loop [buffer (getf :buffer)] 290 | ;; (prlabel wl1 (toks buffer)) 291 | (setf :buffer (into [] buffer)) 292 | (if (not (tokens-fit? this buffer)) 293 | (let [new-buffer (write-token-string this buffer)] 294 | ;; (prlabel wl new-buffer) 295 | (if-not (identical? buffer new-buffer) 296 | (recur new-buffer))))))) 297 | 298 | ;;; Add a buffer token to the buffer and see if it's time to start 299 | ;;; writing 300 | (defn- add-to-buffer [^Writer this token] 301 | ; (prlabel a2b token) 302 | (dosync 303 | (setf :buffer (conj (getf :buffer) token)) 304 | (if (not (tokens-fit? this (getf :buffer))) 305 | (write-line this)))) 306 | 307 | ;;; Write all the tokens that have been buffered 308 | (defn- write-buffered-output [^Writer this] 309 | (write-line this) 310 | (if-let [buf (getf :buffer)] 311 | (do 312 | (write-tokens this buf true) 313 | (setf :buffer [])))) 314 | 315 | (defn- write-white-space [^Writer this] 316 | (when-let [^String tws (getf :trailing-white-space)] 317 | ; (prlabel wws (str "*" tws "*")) 318 | (.write (getf :base) tws) 319 | (dosync 320 | (setf :trailing-white-space nil)))) 321 | 322 | ;;; If there are newlines in the string, print the lines up until the last newline, 323 | ;;; making the appropriate adjustments. Return the remainder of the string 324 | (defn- write-initial-lines 325 | [^Writer this ^String s] 326 | (let [lines (.split s "\n" -1)] 327 | (if (= (count lines) 1) 328 | s 329 | (dosync 330 | (let [^String prefix (:per-line-prefix (first (getf :logical-blocks))) 331 | ^String l (first lines)] 332 | (if (= :buffering (getf :mode)) 333 | (let [oldpos (getf :pos) 334 | newpos (+ oldpos (count l))] 335 | (setf :pos newpos) 336 | (add-to-buffer this (make-buffer-blob l nil oldpos newpos)) 337 | (write-buffered-output this)) 338 | (do 339 | (write-white-space this) 340 | (.write (getf :base) l))) 341 | (.write (getf :base) (int \newline)) 342 | (doseq [^String l (next (butlast lines))] 343 | (.write (getf :base) l) 344 | (.write (getf :base) (pp-newline)) 345 | (if prefix 346 | (.write (getf :base) prefix))) 347 | (setf :buffering :writing) 348 | (last lines)))))) 349 | 350 | 351 | (defn- p-write-char [^Writer this ^Integer c] 352 | (if (= (getf :mode) :writing) 353 | (do 354 | (write-white-space this) 355 | (.write (getf :base) c)) 356 | (if (= c \newline) 357 | (write-initial-lines this "\n") 358 | (let [oldpos (getf :pos) 359 | newpos (inc oldpos)] 360 | (dosync 361 | (setf :pos newpos) 362 | (add-to-buffer this (make-buffer-blob (str (char c)) nil oldpos newpos))))))) 363 | 364 | 365 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 366 | ;;; Initialize the pretty-writer instance 367 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 368 | 369 | 370 | (defn- pretty-writer [writer max-columns miser-width] 371 | (let [lb (struct logical-block nil nil (ref 0) (ref 0) (ref false) (ref false)) 372 | fields (ref {:pretty-writer true 373 | :base (column-writer writer max-columns) 374 | :logical-blocks lb 375 | :sections nil 376 | :mode :writing 377 | :buffer [] 378 | :buffer-block lb 379 | :buffer-level 1 380 | :miser-width miser-width 381 | :trailing-white-space nil 382 | :pos 0})] 383 | (proxy [Writer IDeref PrettyFlush] [] 384 | (deref [] fields) 385 | 386 | (write 387 | ([x] 388 | ;; (prlabel write x (getf :mode)) 389 | (condp = (class x) 390 | String 391 | (let [^String s0 (write-initial-lines this x) 392 | ^String s (.replaceFirst s0 "\\s+$" "") 393 | white-space (.substring s0 (count s)) 394 | mode (getf :mode)] 395 | (dosync 396 | (if (= mode :writing) 397 | (do 398 | (write-white-space this) 399 | (.write (getf :base) s) 400 | (setf :trailing-white-space white-space)) 401 | (let [oldpos (getf :pos) 402 | newpos (+ oldpos (count s0))] 403 | (setf :pos newpos) 404 | (add-to-buffer this (make-buffer-blob s white-space oldpos newpos)))))) 405 | 406 | Integer 407 | (p-write-char this x) 408 | Long 409 | (p-write-char this x)))) 410 | 411 | (ppflush [] 412 | (if (= (getf :mode) :buffering) 413 | (dosync 414 | (write-tokens this (getf :buffer) true) 415 | (setf :buffer [])) 416 | (write-white-space this))) 417 | 418 | (flush [] 419 | (.ppflush this) 420 | (.flush (getf :base))) 421 | 422 | (close [] 423 | (.flush this))))) 424 | 425 | 426 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 427 | ;;; Methods for pretty-writer 428 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 429 | 430 | (defn- start-block 431 | [^Writer this 432 | ^String prefix ^String per-line-prefix ^String suffix] 433 | (dosync 434 | (let [lb (struct logical-block (getf :logical-blocks) nil (ref 0) (ref 0) 435 | (ref false) (ref false) 436 | prefix per-line-prefix suffix)] 437 | (setf :logical-blocks lb) 438 | (if (= (getf :mode) :writing) 439 | (do 440 | (write-white-space this) 441 | (when-let [cb (getf :logical-block-callback)] (cb :start)) 442 | (if prefix 443 | (.write (getf :base) prefix)) 444 | (let [col (get-column (getf :base))] 445 | (ref-set (:start-col lb) col) 446 | (ref-set (:indent lb) col))) 447 | (let [oldpos (getf :pos) 448 | newpos (+ oldpos (if prefix (count prefix) 0))] 449 | (setf :pos newpos) 450 | (add-to-buffer this (make-start-block-t lb oldpos newpos))))))) 451 | 452 | (defn- end-block [^Writer this] 453 | (dosync 454 | (let [lb (getf :logical-blocks) 455 | ^String suffix (:suffix lb)] 456 | (if (= (getf :mode) :writing) 457 | (do 458 | (write-white-space this) 459 | (if suffix 460 | (.write (getf :base) suffix)) 461 | (when-let [cb (getf :logical-block-callback)] (cb :end))) 462 | (let [oldpos (getf :pos) 463 | newpos (+ oldpos (if suffix (count suffix) 0))] 464 | (setf :pos newpos) 465 | (add-to-buffer this (make-end-block-t lb oldpos newpos)))) 466 | (setf :logical-blocks (:parent lb))))) 467 | 468 | (defn- nl [^Writer this type] 469 | (dosync 470 | (setf :mode :buffering) 471 | (let [pos (getf :pos)] 472 | (add-to-buffer this (make-nl-t type (getf :logical-blocks) pos pos))))) 473 | 474 | (defn- indent [^Writer this relative-to offset] 475 | (dosync 476 | (let [lb (getf :logical-blocks)] 477 | (if (= (getf :mode) :writing) 478 | (do 479 | (write-white-space this) 480 | (ref-set (:indent lb) 481 | (+ offset (condp = relative-to 482 | :block @(:start-col lb) 483 | :current (get-column (getf :base)))))) 484 | (let [pos (getf :pos)] 485 | (add-to-buffer this (make-indent-t lb relative-to offset pos pos))))))) 486 | 487 | (defn- get-miser-width [^Writer this] 488 | (getf :miser-width)) 489 | 490 | (defn- set-miser-width [^Writer this new-miser-width] 491 | (dosync (setf :miser-width new-miser-width))) 492 | 493 | (defn- set-logical-block-callback [^Writer this f] 494 | (dosync (setf :logical-block-callback f))) 495 | -------------------------------------------------------------------------------- /src/clj/pprint/print_table.clj: -------------------------------------------------------------------------------- 1 | ; Copyright (c) Rich Hickey. All rights reserved. 2 | ; The use and distribution terms for this software are covered by the 3 | ; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) 4 | ; which can be found in the file epl-v10.html at the root of this distribution. 5 | ; By using this software in any fashion, you are agreeing to be bound by 6 | ; the terms of this license. 7 | ; You must not remove this notice, or any other, from this software. 8 | 9 | (in-ns 'clojure.pprint) 10 | 11 | (defn print-table 12 | "Prints a collection of maps in a textual table. Prints table headings 13 | ks, and then a line of output for each row, corresponding to the keys 14 | in ks. If ks are not specified, use the keys of the first item in rows." 15 | {:added "1.3"} 16 | ([ks rows] 17 | (when (seq rows) 18 | (let [widths (map 19 | (fn [k] 20 | (apply max (count (str k)) (map #(count (str (get % k))) rows))) 21 | ks) 22 | spacers (map #(apply str (repeat % "-")) widths) 23 | fmts (map #(str "%" % "s") widths) 24 | fmt-row (fn [leader divider trailer row] 25 | (str leader 26 | (apply str (interpose divider 27 | (for [[col fmt] (map vector (map #(get row %) ks) fmts)] 28 | (format fmt (str col))))) 29 | trailer))] 30 | (println) 31 | (println (fmt-row "| " " | " " |" (zipmap ks ks))) 32 | (println (fmt-row "|-" "-+-" "-|" (zipmap ks spacers))) 33 | (doseq [row rows] 34 | (println (fmt-row "| " " | " " |" row)))))) 35 | ([rows] (print-table (keys (first rows)) rows))) 36 | -------------------------------------------------------------------------------- /src/clj/pprint/utilities.clj: -------------------------------------------------------------------------------- 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 | 105 | ;; Flush the pretty-print buffer without flushing the underlying stream 106 | (definterface PrettyFlush 107 | (^void ppflush [])) 108 | -------------------------------------------------------------------------------- /src/cljs/cljs/pprint.clj: -------------------------------------------------------------------------------- 1 | (ns cljs.pprint 2 | (:refer-clojure :exclude [deftype]) 3 | (:require [clojure.walk :as walk])) 4 | 5 | 6 | ;; required the following changes: 7 | ;; replace .ppflush with -ppflush to switch from Interface to Protocol 8 | 9 | (defmacro with-pretty-writer [base-writer & body] 10 | `(let [base-writer# ~base-writer 11 | new-writer# (not (pretty-writer? base-writer#))] 12 | (cljs.core/binding [~'*out* (if new-writer# 13 | (make-pretty-writer base-writer# *print-right-margin* *print-miser-width*) 14 | base-writer#)] 15 | ~@body 16 | (-ppflush ~'*out*)))) 17 | 18 | 19 | (defmacro getf 20 | "Get the value of the field a named by the argument (which should be a keyword)." 21 | [sym] 22 | `(~sym @@~'this)) 23 | 24 | ;; change alter to swap! 25 | 26 | (defmacro setf 27 | "Set the value of the field SYM to NEW-VAL" 28 | [sym new-val] 29 | `(swap! @~'this assoc ~sym ~new-val)) 30 | 31 | (defmacro deftype 32 | [type-name & fields] 33 | (let [name-str (name type-name) 34 | fields (map (comp symbol name) fields)] 35 | `(do 36 | (defrecord ~type-name [~'type-tag ~@fields]) 37 | (defn- ~(symbol (str "make-" name-str)) 38 | ~(vec fields) 39 | (~(symbol (str type-name ".")) ~(keyword name-str) ~@fields)) 40 | (defn- ~(symbol (str name-str "?")) [x#] (= (:type-tag x#) ~(keyword name-str)))))) 41 | 42 | (defn- parse-lb-options [opts body] 43 | (loop [body body 44 | acc []] 45 | (if (opts (first body)) 46 | (recur (drop 2 body) (concat acc (take 2 body))) 47 | [(apply hash-map acc) body]))) 48 | 49 | (defmacro pprint-logical-block 50 | "Execute the body as a pretty printing logical block with output to *out* which 51 | must be a pretty printing writer. When used from pprint or cl-format, this can be 52 | assumed. 53 | 54 | This function is intended for use when writing custom dispatch functions. 55 | 56 | Before the body, the caller can optionally specify options: :prefix, :per-line-prefix 57 | and :suffix." 58 | [& args] 59 | (let [[options body] (parse-lb-options #{:prefix :per-line-prefix :suffix} args)] 60 | `(do (if (cljs.pprint/level-exceeded) 61 | (~'-write cljs.pprint/*out* "#") 62 | (do 63 | (cljs.core/binding [cljs.pprint/*current-level* (inc cljs.pprint/*current-level*) 64 | cljs.pprint/*current-length* 0] 65 | (cljs.pprint/start-block cljs.pprint/*out* 66 | ~(:prefix options) 67 | ~(:per-line-prefix options) 68 | ~(:suffix options)) 69 | ~@body 70 | (cljs.pprint/end-block cljs.pprint/*out*)))) 71 | nil))) 72 | 73 | (defn- pll-mod-body [var-sym body] 74 | (letfn [(inner [form] 75 | (if (seq? form) 76 | (let [form (macroexpand form)] 77 | (condp = (first form) 78 | 'loop* form 79 | 'recur (concat `(recur (inc ~var-sym)) (rest form)) 80 | (walk/walk inner identity form))) 81 | form))] 82 | (walk/walk inner identity body))) 83 | 84 | (defmacro print-length-loop 85 | "A version of loop that iterates at most *print-length* times. This is designed 86 | for use in pretty-printer dispatch functions." 87 | [bindings & body] 88 | (let [count-var (gensym "length-count") 89 | mod-body (pll-mod-body count-var body)] 90 | `(loop ~(apply vector count-var 0 bindings) 91 | (if (or (not cljs.core/*print-length*) (< ~count-var cljs.core/*print-length*)) 92 | (do ~@mod-body) 93 | (~'-write cljs.pprint/*out* "..."))))) 94 | 95 | (defn- process-directive-table-element [[char params flags bracket-info & generator-fn]] 96 | [char, 97 | {:directive char, 98 | :params `(array-map ~@params), 99 | :flags flags, 100 | :bracket-info bracket-info, 101 | :generator-fn (concat '(fn [params offset]) generator-fn)}]) 102 | 103 | (defmacro ^{:private true} 104 | defdirectives 105 | [& directives] 106 | `(def ^{:private true} 107 | ~'directive-table (hash-map ~@(mapcat process-directive-table-element directives)))) 108 | 109 | (defmacro formatter 110 | "Makes a function which can directly run format-in. The function is 111 | fn [stream & args] ... and returns nil unless the stream is nil (meaning 112 | output to a string) in which case it returns the resulting string. 113 | 114 | format-in can be either a control string or a previously compiled format." 115 | [format-in] 116 | `(let [format-in# ~format-in 117 | my-c-c# cljs.pprint/cached-compile 118 | my-e-f# cljs.pprint/execute-format 119 | my-i-n# cljs.pprint/init-navigator 120 | cf# (if (string? format-in#) (my-c-c# format-in#) format-in#)] 121 | (fn [stream# & args#] 122 | (let [navigator# (my-i-n# args#)] 123 | (my-e-f# stream# cf# navigator#))))) 124 | 125 | (defmacro formatter-out 126 | "Makes a function which can directly run format-in. The function is 127 | fn [& args] ... and returns nil. This version of the formatter macro is 128 | designed to be used with *out* set to an appropriate Writer. In particular, 129 | this is meant to be used as part of a pretty printer dispatch method. 130 | 131 | format-in can be either a control string or a previously compiled format." 132 | [format-in] 133 | `(let [format-in# ~format-in 134 | cf# (if (string? format-in#) (cljs.pprint/cached-compile format-in#) format-in#)] 135 | (fn [& args#] 136 | (let [navigator# (cljs.pprint/init-navigator args#)] 137 | (cljs.pprint/execute-format cf# navigator#))))) 138 | 139 | (defmacro with-pprint-dispatch 140 | "Execute body with the pretty print dispatch function bound to function." 141 | [function & body] 142 | `(cljs.core/binding [cljs.pprint/*print-pprint-dispatch* ~function] 143 | ~@body)) 144 | 145 | -------------------------------------------------------------------------------- /src/parse/parse/core.clj: -------------------------------------------------------------------------------- 1 | (ns parse.core 2 | (:require 3 | [clojure.java.io :as io] 4 | [clojure.tools.reader :as reader] 5 | [clojure.tools.reader.reader-types :as rt] 6 | [clojure.string :refer [split-lines join]] 7 | [clojure.pprint :refer [pprint]] 8 | [fipp.edn :refer [pprint] :rename {pprint fipp}] 9 | ) 10 | ) 11 | 12 | (def output-name "resources/report/forms.edn") 13 | 14 | ;;------------------------------------------------------------ 15 | ;; Filename utilities 16 | ;;------------------------------------------------------------ 17 | 18 | (defn get-filenames 19 | [dir exts] 20 | (let [files (file-seq (clojure.java.io/file dir)) 21 | filenames (map #(.getPath %) files) 22 | validate (fn [f] (when (some #(.endsWith f %) exts) f))] 23 | (keep validate filenames))) 24 | 25 | (defn isolate-filename 26 | [full-path] 27 | (let [i (.lastIndexOf full-path "/")] 28 | (if (>= i 0) 29 | (subs full-path (inc i)) 30 | i))) 31 | 32 | ;;------------------------------------------------------------ 33 | ;; Form Retrieving 34 | ;;------------------------------------------------------------ 35 | 36 | (defn get-forms-from-file 37 | [path] 38 | (let [is (clojure.java.io/input-stream path) 39 | r1 (rt/input-stream-push-back-reader is) 40 | r (rt/source-logging-push-back-reader r1 1 path)] 41 | (loop [forms (transient [])] 42 | (if-let [f (try (reader/read r) 43 | (catch Exception e 44 | (when-not (= (.getMessage e) "EOF") (throw e))))] 45 | (recur (conj! forms f)) 46 | (persistent! forms))))) 47 | 48 | (defn get-forms-from-files 49 | [paths] 50 | (mapcat get-forms-from-file paths)) 51 | 52 | ;;------------------------------------------------------------ 53 | ;; Form Formatting 54 | ;;------------------------------------------------------------ 55 | 56 | (defn get-def-name 57 | [form] 58 | (let [[a b c] form 59 | aname (name a)] 60 | (when (and (.startsWith aname "def") 61 | (not= aname "defdirectives")) 62 | (if (= "defmethod" aname) 63 | [a b c] 64 | [a b])))) 65 | 66 | (defn form-key 67 | [name-form] 68 | (let [[type- name- key-] name-form] 69 | (if key- 70 | (str name- " " key-) 71 | (str name-)))) 72 | 73 | (defn form-data 74 | [form] 75 | (let [m (meta form) 76 | name- (get-def-name form) 77 | num-lines (inc (- (:end-line m) (:line m)))] 78 | (if name- 79 | {;:form form 80 | :type (str (first name-)) 81 | :key (form-key name-) 82 | :lines [(:line m) (:end-line m)] 83 | :filename (isolate-filename (:file m)) 84 | :source (join "\n" (take-last num-lines (split-lines (:source m)))) 85 | }))) 86 | 87 | ;;------------------------------------------------------------ 88 | ;; Form Storing 89 | ;;------------------------------------------------------------ 90 | 91 | (def clj-forms (atom {})) 92 | (def cljs-forms (atom {})) 93 | 94 | (defn make-form-map 95 | [atom- dir exts] 96 | (let [values (vec (keep form-data (get-forms-from-files (get-filenames dir exts)))) 97 | names (map :key values)] 98 | (reset! atom- (zipmap names values)))) 99 | 100 | (defn make-all-form-maps 101 | [] 102 | (make-form-map clj-forms "src/clj" [".clj"]) 103 | (make-form-map cljs-forms "src/cljs/" [".clj" ".cljs"])) 104 | 105 | (defn make-file-def-list 106 | [forms] 107 | (->> (keys forms) 108 | (sort-by #(get-in forms [% :lines 0])) 109 | (group-by #(get-in forms [% :filename])))) 110 | 111 | ;;------------------------------------------------------------ 112 | ;; Program Entry 113 | ;;------------------------------------------------------------ 114 | 115 | (defn -main 116 | [] 117 | (println "Retrieving forms...") 118 | (make-all-form-maps) 119 | (println (str "Writing forms to " output-name "...")) 120 | (spit output-name (with-out-str (fipp {:clj-files (make-file-def-list @clj-forms) 121 | :cljs-files (make-file-def-list @cljs-forms) 122 | :clj @clj-forms 123 | :cljs @cljs-forms}))) 124 | (println "Done.") 125 | ) 126 | -------------------------------------------------------------------------------- /src/report/report/core.cljs: -------------------------------------------------------------------------------- 1 | (ns report.core 2 | (:require-macros 3 | [cljs.core.async.macros :refer [go go-loop]] 4 | [hiccups.core :refer [html defhtml]]) 5 | (:require 6 | [cljs.core.async :refer [chan html]] 11 | [cljsjs.jquery])) 12 | 13 | (enable-console-print!) 14 | 15 | (def forms nil) 16 | (def progress nil) 17 | (def welcome nil) 18 | 19 | (defn welcome-section 20 | [] 21 | [:div.header 22 | (md->html welcome 23 | :reference-links? true)]) 24 | 25 | (defn file-toc-section 26 | [filename defs] 27 | (list 28 | [:h3 filename] 29 | [:table.def-table 30 | (for [d defs] 31 | [:tr [:td.num (get-in forms [:clj d :lines 0])] 32 | [:td 33 | (if (contains? progress d) 34 | [:a.toc-link {:href (str "#" d)} d] 35 | d)]])])) 36 | 37 | (defn toc-section 38 | [] 39 | [:div.toc 40 | [:h2 "Progress"] 41 | [:p "These are the original clojure.pprint files and respective defs that need to be ported. Line numbers are displayed too."] 42 | [:p "The " [:span.toc-link "green names"] " are currently ported; " [:u "click them"] " to see the original and ported versions together."] 43 | [:table.file-table 44 | [:tr 45 | (for [[filename defs] (sort-by first (:clj-files forms))] 46 | [:td (file-toc-section filename defs)])]]]) 47 | 48 | (defn func-head 49 | ([form] (func-head form false)) 50 | ([form create-anchor?] 51 | (let [name- (:key form) 52 | filename (:filename form) 53 | lines (join "-" (:lines form)) 54 | name-content [:span.func-name name-]] 55 | [:div.func-head 56 | (if create-anchor? 57 | [:a.def-anchor {:name name- :href (str "#" name-)} name-content] 58 | name-content) 59 | " @ " filename " : " lines]))) 60 | 61 | (defn code-block 62 | [form] 63 | [:table.code-block 64 | [:tr 65 | [:td.lines [:pre [:code 66 | (join "\n" (range (-> form :lines first) 67 | (-> form :lines second inc)))]]] 68 | [:td [:pre [:code.clojure (:source form)]]]]]) 69 | 70 | (defn code-compare-def 71 | [[orig-name p]] 72 | (let [orig (get-in forms [:clj orig-name]) 73 | p (if (= :same-name p) orig-name p) 74 | port-names (if (sequential? p) p [p]) 75 | ports (map #(get-in forms [:cljs %]) port-names)] 76 | [:table.code-compare-table 77 | [:tr.header 78 | [:td (func-head orig true)] 79 | [:td (map func-head ports)]] 80 | [:tr.code 81 | [:td (code-block orig)] 82 | [:td (map code-block ports)]]])) 83 | 84 | (defn code-compare-section 85 | [] 86 | [:div.code-compare-section 87 | [:table.code-compare-table 88 | [:tr.header-row 89 | [:td [:h1 "Clojure (left)"] "original clojure.pprint functions"] 90 | [:td [:h1 "ClojureScript (right)"] "new ported functions"]]] 91 | 92 | (map code-compare-def progress)]) 93 | 94 | (defn page [] 95 | (html 96 | [:div 97 | (welcome-section) 98 | (toc-section) 99 | (code-compare-section)])) 100 | 101 | (defn highlight-code! 102 | [] 103 | (.each (js/$ "pre code") 104 | (fn [i block] 105 | (.highlightBlock js/hljs block)))) 106 | 107 | (defn force-hash-nav! 108 | [] 109 | (let [h (aget js/location "hash")] 110 | (aset js/location "hash" "") 111 | (aset js/location "hash" h))) 112 | 113 | (defn re-render 114 | [] 115 | (let [e (. js/document (getElementById "app"))] 116 | (aset e "innerHTML" (page))) 117 | (highlight-code!) 118 | (force-hash-nav!)) 119 | 120 | (defn get-async 121 | [url res-format] 122 | (let [c (chan) 123 | handler (fn [data] (put! c data) (close! c))] 124 | (GET url {:response-format res-format :handler handler}) 125 | c)) 126 | 127 | (defn fetch-all 128 | [urls] 129 | (->> urls 130 | (map #(get-async (first %) (second %))) 131 | (zipmap (keys urls)))) 132 | 133 | (defn main 134 | [] 135 | (let [downloads (fetch-all {"forms.edn" :edn 136 | "progress.edn" :edn 137 | "welcome.md" :raw})] 138 | (go 139 | (set! forms (~:;[~D,~D]~]~}~%" [ ]) 397 | "Coordinates are\n" 398 | 399 | (cl-format nil "Coordinates are~{ ~#[none~;<~D>~:;[~D,~D]~]~:}~%" [ ]) 400 | "Coordinates are none\n" 401 | 402 | (cl-format nil "Coordinates are~{ ~#[none~;<~D>~:;[~D,~D]~]~:}~%" [2 3 1]) 403 | "Coordinates are [2,3] <1>\n" 404 | 405 | (cl-format nil "Coordinates are~{~:}~%" "" []) 406 | "Coordinates are\n" 407 | 408 | (cl-format nil "Coordinates are~{~:}~%" " ~#[none~;<~D>~:;[~D,~D]~]" [2 3 1]) 409 | "Coordinates are [2,3] <1>\n" 410 | 411 | (cl-format nil "Coordinates are~{~:}~%" " ~#[none~;<~D>~:;[~D,~D]~]" [ ]) 412 | "Coordinates are none\n" 413 | ) 414 | 415 | 416 | (simple-tests curly-brace-colon-tests 417 | ;; Iteration from list of sublists 418 | (cl-format nil "Coordinates are~:{ [~D,~D]~}~%" [ [0, 1], [1, 0], [3, 5], [2, 1] ]) 419 | "Coordinates are [0,1] [1,0] [3,5] [2,1]\n" 420 | 421 | (cl-format nil "Coordinates are~:{ [~D,~D]~}~%" [ [0, 1, 0], [1, 0, 12], [3, 5], [2, 1] ]) 422 | "Coordinates are [0,1] [1,0] [3,5] [2,1]\n" 423 | 424 | (cl-format nil "Coordinates are~2:{ [~D,~D]~}~%" [ [0, 1], [1, 0], [3, 5], [2, 1] ]) 425 | "Coordinates are [0,1] [1,0]\n" 426 | 427 | (cl-format nil "Coordinates are~:{ ~#[none~;<~D>~:;[~D,~D]~]~}~%" [ ]) 428 | "Coordinates are\n" 429 | 430 | (cl-format nil "Coordinates are~:{ ~#[none~;<~D>~:;[~D,~D]~]~:}~%" [ ]) 431 | "Coordinates are none\n" 432 | 433 | (cl-format nil "Coordinates are~:{ ~#[none~;<~D>~:;[~D,~D]~]~:}~%" [[2 3] [1]]) 434 | "Coordinates are [2,3] <1>\n" 435 | 436 | (cl-format nil "Coordinates are~:{~:}~%" "" []) 437 | "Coordinates are\n" 438 | 439 | (cl-format nil "Coordinates are~:{~:}~%" " ~#[none~;<~D>~:;[~D,~D]~]" [[2 3] [1]]) 440 | "Coordinates are [2,3] <1>\n" 441 | 442 | (cl-format nil "Coordinates are~:{~:}~%" " ~#[none~;<~D>~:;[~D,~D]~]" [ ]) 443 | "Coordinates are none\n" 444 | ) 445 | 446 | (simple-tests curly-brace-at-tests 447 | ;; Iteration from main list 448 | (cl-format nil "Coordinates are~@{ [~D,~D]~}~%" 0, 1, 1, 0, 3, 5, 2, 1) 449 | "Coordinates are [0,1] [1,0] [3,5] [2,1]\n" 450 | 451 | (cl-format nil "Coordinates are~2@{ [~D,~D]~}~%" 0, 1, 1, 0, 3, 5, 2, 1) 452 | "Coordinates are [0,1] [1,0]\n" 453 | 454 | (cl-format nil "Coordinates are~@{ ~#[none~;<~D>~:;[~D,~D]~]~}~%") 455 | "Coordinates are\n" 456 | 457 | (cl-format nil "Coordinates are~@{ ~#[none~;<~D>~:;[~D,~D]~]~:}~%") 458 | "Coordinates are none\n" 459 | 460 | (cl-format nil "Coordinates are~@{ ~#[none~;<~D>~:;[~D,~D]~]~:}~%" 2 3 1) 461 | "Coordinates are [2,3] <1>\n" 462 | 463 | (cl-format nil "Coordinates are~@{~:}~%" "") 464 | "Coordinates are\n" 465 | 466 | (cl-format nil "Coordinates are~@{~:}~%" " ~#[none~;<~D>~:;[~D,~D]~]" 2 3 1) 467 | "Coordinates are [2,3] <1>\n" 468 | 469 | (cl-format nil "Coordinates are~@{~:}~%" " ~#[none~;<~D>~:;[~D,~D]~]") 470 | "Coordinates are none\n" 471 | ) 472 | 473 | (simple-tests curly-brace-colon-at-tests 474 | ;; Iteration from sublists on the main arg list 475 | (cl-format nil "Coordinates are~@:{ [~D,~D]~}~%" [0, 1], [1, 0], [3, 5], [2, 1] ) 476 | "Coordinates are [0,1] [1,0] [3,5] [2,1]\n" 477 | 478 | (cl-format nil "Coordinates are~@:{ [~D,~D]~}~%" [0, 1, 0], [1, 0, 12], [3, 5], [2, 1] ) 479 | "Coordinates are [0,1] [1,0] [3,5] [2,1]\n" 480 | 481 | (cl-format nil "Coordinates are~2@:{ [~D,~D]~}~%" [0, 1], [1, 0], [3, 5], [2, 1]) 482 | "Coordinates are [0,1] [1,0]\n" 483 | 484 | (cl-format nil "Coordinates are~@:{ ~#[none~;<~D>~:;[~D,~D]~]~}~%") 485 | "Coordinates are\n" 486 | 487 | (cl-format nil "Coordinates are~@:{ ~#[none~;<~D>~:;[~D,~D]~]~:}~%") 488 | "Coordinates are none\n" 489 | 490 | (cl-format nil "Coordinates are~@:{ ~#[none~;<~D>~:;[~D,~D]~]~:}~%" [2 3] [1]) 491 | "Coordinates are [2,3] <1>\n" 492 | 493 | (cl-format nil "Coordinates are~@:{~:}~%" "") 494 | "Coordinates are\n" 495 | 496 | (cl-format nil "Coordinates are~@:{~:}~%" " ~#[none~;<~D>~:;[~D,~D]~]" [2 3] [1]) 497 | "Coordinates are [2,3] <1>\n" 498 | 499 | (cl-format nil "Coordinates are~@:{~:}~%" " ~#[none~;<~D>~:;[~D,~D]~]") 500 | "Coordinates are none\n" 501 | ) 502 | 503 | ;; TODO tests for ~^ in ~[ constructs and other brackets 504 | ;; TODO test ~:^ generates an error when used improperly 505 | ;; TODO test ~:^ works in ~@:{...~} 506 | (let [aseq '(a quick brown fox jumped over the lazy dog) 507 | lseq (mapcat identity (for [x aseq] [x (.length (name x))]))] 508 | (simple-tests up-tests 509 | (cl-format nil "~{~a~^, ~}" aseq) "a, quick, brown, fox, jumped, over, the, lazy, dog" 510 | (cl-format nil "~{~a~0^, ~}" aseq) "a" 511 | (cl-format nil "~{~a~#,3^, ~}" aseq) "a, quick, brown, fox, jumped, over" 512 | (cl-format nil "~{~a~v,3^, ~}" lseq) "a, quick, brown, fox" 513 | (cl-format nil "~{~a~3,v,4^, ~}" lseq) "a, quick, brown, fox" 514 | )) 515 | 516 | (simple-tests angle-bracket-tests 517 | (cl-format nil "~") "foobarbaz" 518 | (cl-format nil "~20") "foo bar baz" 519 | (cl-format nil "~,,2") "foo bar baz" 520 | (cl-format nil "~20<~A~;~A~;~A~>" "foo" "bar" "baz") "foo bar baz" 521 | (cl-format nil "~20:<~A~;~A~;~A~>" "foo" "bar" "baz") " foo bar baz" 522 | (cl-format nil "~20@<~A~;~A~;~A~>" "foo" "bar" "baz") "foo bar baz " 523 | (cl-format nil "~20@:<~A~;~A~;~A~>" "foo" "bar" "baz") " foo bar baz " 524 | (cl-format nil "~10,,2<~A~;~A~;~A~>" "foo" "bar" "baz") "foo bar baz" 525 | (cl-format nil "~10,10,2<~A~;~A~;~A~>" "foo" "bar" "baz") "foo bar baz" 526 | (cl-format nil "~10,10<~A~;~A~;~A~>" "foo" "bar" "baz") "foo barbaz" 527 | (cl-format nil "~20<~A~;~^~A~;~^~A~>" "foo" "bar" "baz") "foo bar baz" 528 | (cl-format nil "~20<~A~;~^~A~;~^~A~>" "foo" "bar") "foo bar" 529 | (cl-format nil "~20@<~A~;~^~A~;~^~A~>" "foo") "foo " 530 | (cl-format nil "~20:<~A~;~^~A~;~^~A~>" "foo") " foo" 531 | ) 532 | 533 | (simple-tests angle-bracket-max-column-tests 534 | (cl-format nil "~%;; ~{~<~%;; ~1,50:; ~A~>~}.~%" (into [] (.split "This function computes the circular thermodynamic coefficient of the thrombulator angle for use in determining the reaction distance" "\\s"))) 535 | "\n;; This function computes the circular\n;; thermodynamic coefficient of the thrombulator\n;; angle for use in determining the reaction\n;; distance.\n" 536 | (cl-format true "~%;; ~{~<~%;; ~:; ~A~>~}.~%" (into [] (.split "This function computes the circular thermodynamic coefficient of the thrombulator angle for use in determining the reaction distance." "\\s")))) 537 | 538 | (defn list-to-table [aseq column-width] 539 | (let [stream (get-pretty-writer (java.io.StringWriter.))] 540 | (binding [*out* stream] 541 | (doseq [row aseq] 542 | (doseq [col row] 543 | (cl-format true "~4D~7,vT" col column-width)) 544 | (prn))) 545 | (.flush stream) 546 | (.toString (:base @@(:base @@stream))))) 547 | 548 | (simple-tests column-writer-test 549 | (list-to-table (map #(vector % (* % %) (* % % %)) (range 1 21)) 8) 550 | " 1 1 1 \n 2 4 8 \n 3 9 27 \n 4 16 64 \n 5 25 125 \n 6 36 216 \n 7 49 343 \n 8 64 512 \n 9 81 729 \n 10 100 1000 \n 11 121 1331 \n 12 144 1728 \n 13 169 2197 \n 14 196 2744 \n 15 225 3375 \n 16 256 4096 \n 17 289 4913 \n 18 324 5832 \n 19 361 6859 \n 20 400 8000 \n") 551 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 552 | ;; The following tests are the various examples from the format 553 | ;; documentation in Common Lisp, the Language, 2nd edition, Chapter 22.3 554 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 555 | 556 | (defn expt [base pow] (reduce * (repeat pow base))) 557 | 558 | (let [x 5, y "elephant", n 3] 559 | (simple-tests cltl-intro-tests 560 | (format nil "foo") "foo" 561 | (format nil "The answer is ~D." x) "The answer is 5." 562 | (format nil "The answer is ~3D." x) "The answer is 5." 563 | (format nil "The answer is ~3,'0D." x) "The answer is 005." 564 | (format nil "The answer is ~:D." (expt 47 x)) "The answer is 229,345,007." 565 | (format nil "Look at the ~A!" y) "Look at the elephant!" 566 | (format nil "Type ~:C to ~A." (char 4) "delete all your files") 567 | "Type Control-D to delete all your files." 568 | (format nil "~D item~:P found." n) "3 items found." 569 | (format nil "~R dog~:[s are~; is~] here." n (= n 1)) "three dogs are here." 570 | (format nil "~R dog~:*~[s are~; is~:;s are~] here." n) "three dogs are here." 571 | (format nil "Here ~[are~;is~:;are~] ~:*~R pupp~:@P." n) "Here are three puppies.")) 572 | 573 | (simple-tests cltl-B-tests 574 | ;; CLtL didn't have the colons here, but the spec requires them 575 | (format nil "~,,' ,4:B" 0xFACE) "1111 1010 1100 1110" 576 | (format nil "~,,' ,4:B" 0x1CE) "1 1100 1110" 577 | (format nil "~19,,' ,4:B" 0xFACE) "1111 1010 1100 1110" 578 | ;; This one was a nice idea, but nothing in the spec supports it working this way 579 | ;; (and SBCL doesn't work this way either) 580 | ;(format nil "~19,,' ,4:B" 0x1CE) "0000 0001 1100 1110") 581 | ) 582 | 583 | (simple-tests cltl-P-tests 584 | (format nil "~D tr~:@P/~D win~:P" 7 1) "7 tries/1 win" 585 | (format nil "~D tr~:@P/~D win~:P" 1 0) "1 try/0 wins" 586 | (format nil "~D tr~:@P/~D win~:P" 1 3) "1 try/3 wins") 587 | 588 | (defn foo [x] 589 | (format nil "~6,2F|~6,2,1,'*F|~6,2,,'?F|~6F|~,2F|~F" 590 | x x x x x x)) 591 | 592 | ;; big-pos-ratio is a ratio value that is larger than 593 | ;; Double/MAX_VALUE, and has a non-terminating decimal representation 594 | ;; if you attempt to represent it exactly. 595 | (def big-pos-ratio (/ (* 4 (bigint (. BigDecimal valueOf Double/MAX_VALUE))) 3)) 596 | (def big-neg-ratio (- big-pos-ratio)) 597 | ;; tiny-pos-ratio is a ratio between 0 and Double/MIN_VALUE. 598 | (def tiny-pos-ratio (/ 1 (bigint (apply str (cons "1" (repeat 340 "0")))))) 599 | (def tiny-neg-ratio (- tiny-pos-ratio)) 600 | 601 | (simple-tests cltl-F-tests 602 | (cl-format false "~10,3f" 4/5) " 0.800" 603 | (binding [*math-context* java.math.MathContext/DECIMAL128] 604 | (cl-format false "~10,3f" big-pos-ratio)) "239692417981642093333333333333333300000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000.000" 605 | (binding [*math-context* java.math.MathContext/DECIMAL128] 606 | (cl-format false "~10,3f" big-neg-ratio)) "-239692417981642093333333333333333300000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000.000" 607 | (binding [*math-context* java.math.MathContext/DECIMAL128] 608 | (cl-format false "~10,3f" tiny-pos-ratio)) " 0.000" 609 | (binding [*math-context* java.math.MathContext/DECIMAL128] 610 | (cl-format false "~10,3f" tiny-neg-ratio)) " -0.000" 611 | (foo 3.14159) " 3.14| 31.42| 3.14|3.1416|3.14|3.14159" 612 | (foo 314159/100000) 613 | " 3.14| 31.42| 3.14|3.1416|3.14|3.14159" 614 | (foo -3.14159) " -3.14|-31.42| -3.14|-3.142|-3.14|-3.14159" 615 | (foo 100.0) "100.00|******|100.00| 100.0|100.00|100.0" 616 | (foo 1234.0) "1234.00|******|??????|1234.0|1234.00|1234.0" 617 | (foo 0.006) " 0.01| 0.06| 0.01| 0.006|0.01|0.006") 618 | 619 | (defn foo-e [x] 620 | (format nil 621 | "~9,2,1,,'*E|~10,3,2,2,'?,,'$E|~9,3,2,-2,'%@E|~9,2E" 622 | x x x x)) 623 | 624 | ;; Clojure doesn't support float/double differences in representation 625 | (simple-tests cltl-E-tests 626 | (cl-format false "~10,3e" 4/5) " 8.000E-1" 627 | (binding [*math-context* java.math.MathContext/DECIMAL128] 628 | (cl-format false "~10,3e" big-pos-ratio)) "2.397E+308" 629 | (binding [*math-context* java.math.MathContext/DECIMAL128] 630 | (cl-format false "~10,3e" big-neg-ratio)) "-2.397E+308" 631 | (binding [*math-context* java.math.MathContext/DECIMAL128] 632 | (cl-format false "~10,3e" tiny-pos-ratio)) "1.000E-340" 633 | (binding [*math-context* java.math.MathContext/DECIMAL128] 634 | (cl-format false "~10,3e" tiny-neg-ratio)) "-1.000E-340" 635 | (foo-e 0.0314159) " 3.14E-2| 31.42$-03|+.003E+01| 3.14E-2" ; Added this one 636 | (foo-e 314159/10000000) 637 | " 3.14E-2| 31.42$-03|+.003E+01| 3.14E-2" 638 | (foo-e 3.14159) " 3.14E+0| 31.42$-01|+.003E+03| 3.14E+0" 639 | (foo-e -3.14159) " -3.14E+0|-31.42$-01|-.003E+03| -3.14E+0" 640 | (foo-e 1100.0) " 1.10E+3| 11.00$+02|+.001E+06| 1.10E+3" 641 | ; In Clojure, this is identical to the above 642 | ; (foo-e 1100.0L0) " 1.10L+3| 11.00$+02|+.001L+06| 1.10L+3" 643 | (foo-e 1.1E13) "*********| 11.00$+12|+.001E+16| 1.10E+13" 644 | (foo-e 1.1E120) "*********|??????????|%%%%%%%%%|1.10E+120" 645 | ; Clojure doesn't support real numbers this large 646 | ; (foo-e 1.1L1200) "*********|??????????|%%%%%%%%%|1.10L+1200" 647 | ) 648 | 649 | (simple-tests cltl-E-scale-tests 650 | (map 651 | (fn [k] (format nil "Scale factor ~2D~:*: |~13,6,2,VE|" 652 | (- k 5) 3.14159)) ;Prints 13 lines 653 | (range 13)) 654 | '("Scale factor -5: | 0.000003E+06|" 655 | "Scale factor -4: | 0.000031E+05|" 656 | "Scale factor -3: | 0.000314E+04|" 657 | "Scale factor -2: | 0.003142E+03|" 658 | "Scale factor -1: | 0.031416E+02|" 659 | "Scale factor 0: | 0.314159E+01|" 660 | "Scale factor 1: | 3.141590E+00|" 661 | "Scale factor 2: | 31.41590E-01|" 662 | "Scale factor 3: | 314.1590E-02|" 663 | "Scale factor 4: | 3141.590E-03|" 664 | "Scale factor 5: | 31415.90E-04|" 665 | "Scale factor 6: | 314159.0E-05|" 666 | "Scale factor 7: | 3141590.E-06|")) 667 | 668 | (defn foo-g [x] 669 | (format nil 670 | "~9,2,1,,'*G|~9,3,2,3,'?,,'$G|~9,3,2,0,'%G|~9,2G" 671 | x x x x)) 672 | 673 | ;; Clojure doesn't support float/double differences in representation 674 | (simple-tests cltl-G-tests 675 | (cl-format false "~10,3g" 4/5) " 0.800 " 676 | (binding [*math-context* java.math.MathContext/DECIMAL128] 677 | (cl-format false "~10,3g" big-pos-ratio)) "2.397E+308" 678 | (binding [*math-context* java.math.MathContext/DECIMAL128] 679 | (cl-format false "~10,3g" big-neg-ratio)) "-2.397E+308" 680 | (binding [*math-context* java.math.MathContext/DECIMAL128] 681 | (cl-format false "~10,3g" tiny-pos-ratio)) "1.000E-340" 682 | (binding [*math-context* java.math.MathContext/DECIMAL128] 683 | (cl-format false "~10,3g" tiny-neg-ratio)) "-1.000E-340" 684 | (foo-g 0.0314159) " 3.14E-2|314.2$-04|0.314E-01| 3.14E-2" 685 | (foo-g 314159/10000000) 686 | " 3.14E-2|314.2$-04|0.314E-01| 3.14E-2" 687 | (foo-g 0.314159) " 0.31 |0.314 |0.314 | 0.31 " 688 | (foo-g 3.14159) " 3.1 | 3.14 | 3.14 | 3.1 " 689 | (foo-g 31.4159) " 31. | 31.4 | 31.4 | 31. " 690 | (foo-g 314.159) " 3.14E+2| 314. | 314. | 3.14E+2" 691 | (foo-g 3141.59) " 3.14E+3|314.2$+01|0.314E+04| 3.14E+3" 692 | ; In Clojure, this is identical to the above 693 | ; (foo-g 3141.59L0) " 3.14L+3|314.2$+01|0.314L+04| 3.14L+3" 694 | (foo-g 3.14E12) "*********|314.0$+10|0.314E+13| 3.14E+12" 695 | (foo-g 3.14E120) "*********|?????????|%%%%%%%%%|3.14E+120" 696 | ; Clojure doesn't support real numbers this large 697 | ; (foo-g 3.14L1200) "*********|?????????|%%%%%%%%%|3.14L+1200" 698 | ) 699 | 700 | (defn type-clash-error [fun nargs argnum right-type wrong-type] 701 | (format nil ;; CLtL has this format string slightly wrong 702 | "~&Function ~S requires its ~:[~:R ~;~*~]~ 703 | argument to be of type ~S,~%but it was called ~ 704 | with an argument of type ~S.~%" 705 | fun (= nargs 1) argnum right-type wrong-type)) 706 | 707 | (simple-tests cltl-Newline-tests 708 | (type-clash-error 'aref nil 2 'integer 'vector) 709 | "Function aref requires its second argument to be of type integer, 710 | but it was called with an argument of type vector.\n" 711 | (type-clash-error 'car 1 1 'list 'short-float) 712 | "Function car requires its argument to be of type list, 713 | but it was called with an argument of type short-float.\n") 714 | 715 | (simple-tests cltl-?-tests 716 | (format nil "~? ~D" "<~A ~D>" '("Foo" 5) 7) " 7" 717 | (format nil "~? ~D" "<~A ~D>" '("Foo" 5 14) 7) " 7" 718 | (format nil "~@? ~D" "<~A ~D>" "Foo" 5 7) " 7" 719 | (format nil "~@? ~D" "<~A ~D>" "Foo" 5 14 7) " 14") 720 | 721 | (defn f [n] (format nil "~@(~R~) error~:P detected." n)) 722 | 723 | (simple-tests cltl-paren-tests 724 | (format nil "~@R ~(~@R~)" 14 14) "XIV xiv" 725 | (f 0) "Zero errors detected." 726 | (f 1) "One error detected." 727 | (f 23) "Twenty-three errors detected.") 728 | 729 | (let [*print-level* nil *print-length* 5] 730 | (simple-tests cltl-bracket-tests 731 | (format nil "~@[ print level = ~D~]~@[ print length = ~D~]" 732 | *print-level* *print-length*) 733 | " print length = 5")) 734 | 735 | (let [foo "Items:~#[ none~; ~S~; ~S and ~S~ 736 | ~:;~@{~#[~; and~] ~ 737 | ~S~^,~}~]."] 738 | (simple-tests cltl-bracket1-tests 739 | (format nil foo) "Items: none." 740 | (format nil foo 'foo) "Items: foo." 741 | (format nil foo 'foo 'bar) "Items: foo and bar." 742 | (format nil foo 'foo 'bar 'baz) "Items: foo, bar, and baz." 743 | (format nil foo 'foo 'bar 'baz 'quux) "Items: foo, bar, baz, and quux.")) 744 | 745 | (simple-tests cltl-curly-bracket-tests 746 | (format nil 747 | "The winners are:~{ ~S~}." 748 | '(fred harry jill)) 749 | "The winners are: fred harry jill." 750 | 751 | (format nil "Pairs:~{ <~S,~S>~}." '(a 1 b 2 c 3)) 752 | "Pairs: ." 753 | 754 | (format nil "Pairs:~:{ <~S,~S>~}." '((a 1) (b 2) (c 3))) 755 | "Pairs: ." 756 | 757 | (format nil "Pairs:~@{ <~S,~S>~}." 'a 1 'b 2 'c 3) 758 | "Pairs: ." 759 | 760 | (format nil "Pairs:~:@{ <~S,~S>~}." '(a 1) '(b 2) '(c 3)) 761 | "Pairs: .") 762 | 763 | (simple-tests cltl-angle-bracket-tests 764 | (format nil "~10") "foo bar" 765 | (format nil "~10:") " foo bar" 766 | (format nil "~10:@") " foo bar " 767 | (format nil "~10") " foobar" 768 | (format nil "~10:") " foobar" 769 | (format nil "~10@") "foobar " 770 | (format nil "~10:@") " foobar ") 771 | 772 | (let [donestr "Done.~^ ~D warning~:P.~^ ~D error~:P." 773 | tellstr "~@{~@(~@[~R~^ ~]~A~)~}."] ;; The CLtL example is a little wrong here 774 | 775 | (simple-tests cltl-up-tests 776 | (format nil donestr) "Done." 777 | (format nil donestr 3) "Done. 3 warnings." 778 | (format nil donestr 1 5) "Done. 1 warning. 5 errors." 779 | (format nil tellstr 23) "Twenty-three." 780 | (format nil tellstr nil "losers") "Losers." 781 | (format nil tellstr 23 "losers") "Twenty-three losers." 782 | (format nil "~15<~S~;~^~S~;~^~S~>" 'foo) 783 | " foo" 784 | (format nil "~15<~S~;~^~S~;~^~S~>" 'foo 'bar) 785 | "foo bar" 786 | (format nil "~15<~S~;~^~S~;~^~S~>" 'foo 'bar 'baz) 787 | "foo bar baz")) 788 | 789 | (simple-tests cltl-up-x3j13-tests 790 | (format nil 791 | "~:{/~S~^ ...~}" 792 | '((hot dog) (hamburger) (ice cream) (french fries))) 793 | "/hot .../hamburger/ice .../french ..." 794 | (format nil 795 | "~:{/~S~:^ ...~}" 796 | '((hot dog) (hamburger) (ice cream) (french fries))) 797 | "/hot .../hamburger .../ice .../french" 798 | 799 | (format nil 800 | "~:{/~S~#:^ ...~}" ;; This is wrong in CLtL 801 | '((hot dog) (hamburger) (ice cream) (french fries))) 802 | "/hot .../hamburger") 803 | 804 | (simple-tests pprint-table-tests 805 | (with-out-str 806 | (print-table [:b :a] 807 | [{:a 1 :b {:a 'is-a} :c ["hi" "there"]} 808 | {:b 5 :a 7 :c "dog" :d -700}])) 809 | " 810 | | :b | :a | 811 | |-----------+----| 812 | | {:a is-a} | 1 | 813 | | 5 | 7 | 814 | " 815 | (with-out-str 816 | (print-table [:a :e :d :c] 817 | [{:a 54.7e17 :b {:a 'is-a} :c ["hi" "there"]} 818 | {:b 5 :a -2/3 :c "dog" :d 'panda}])) 819 | " 820 | | :a | :e | :d | :c | 821 | |---------+----+-------+----------------| 822 | | 5.47E18 | | | [\"hi\" \"there\"] | 823 | | -2/3 | | panda | dog | 824 | " 825 | ) 826 | -------------------------------------------------------------------------------- /test/clj/pprint/test_helper.clj: -------------------------------------------------------------------------------- 1 | ;;; test_helper.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 | 15 | ;; This is just a macro to make my tests a little cleaner 16 | 17 | (ns clojure.test-clojure.pprint.test-helper 18 | (:use [clojure.test :only (deftest is)] 19 | [clojure.test-helper :only [platform-newlines]])) 20 | 21 | (defn- back-match [x y] (re-matches y x)) 22 | 23 | (defmacro simple-tests [name & test-pairs] 24 | `(deftest ~name 25 | ~@(for [[x y] (partition 2 test-pairs)] 26 | (cond 27 | (instance? java.util.regex.Pattern y) 28 | `(is (#'clojure.test-clojure.pprint.test-helper/back-match ~x ~y)) 29 | (instance? java.lang.String y) `(is (= ~x (platform-newlines ~y))) 30 | :else `(is (= ~x ~y)))))) 31 | 32 | -------------------------------------------------------------------------------- /test/clj/pprint/test_pretty.clj: -------------------------------------------------------------------------------- 1 | ;;; test_pretty.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 | 15 | (in-ns 'clojure.test-clojure.pprint) 16 | 17 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 18 | ;;; 19 | ;;; Unit tests for the pretty printer 20 | ;;; 21 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 22 | 23 | (simple-tests xp-fill-test 24 | (binding [*print-pprint-dispatch* simple-dispatch 25 | *print-right-margin* 38 26 | *print-miser-width* nil] 27 | (cl-format nil "(let ~:<~@{~:<~w ~_~w~:>~^ ~:_~}~:>~_ ...)~%" 28 | '((x 4) (*print-length* nil) (z 2) (list nil)))) 29 | "(let ((x 4) (*print-length* nil)\n (z 2) (list nil))\n ...)\n" 30 | 31 | (binding [*print-pprint-dispatch* simple-dispatch 32 | *print-right-margin* 22] 33 | (cl-format nil "(let ~:<~@{~:<~w ~_~w~:>~^ ~:_~}~:>~_ ...)~%" 34 | '((x 4) (*print-length* nil) (z 2) (list nil)))) 35 | "(let ((x 4)\n (*print-length*\n nil)\n (z 2)\n (list nil))\n ...)\n") 36 | 37 | (simple-tests xp-miser-test 38 | (binding [*print-pprint-dispatch* simple-dispatch 39 | *print-right-margin* 10, *print-miser-width* 9] 40 | (cl-format nil "~:" '(first second third))) 41 | "(LIST\n first\n second\n third)" 42 | 43 | (binding [*print-pprint-dispatch* simple-dispatch 44 | *print-right-margin* 10, *print-miser-width* 8] 45 | (cl-format nil "~:" '(first second third))) 46 | "(LIST first second third)") 47 | 48 | (simple-tests mandatory-fill-test 49 | (cl-format nil 50 | "
~%~~%
~%" 51 | [ "hello" "gooodbye" ]) 52 | "
 53 | Usage: *hello*
 54 |        *gooodbye*
 55 |
56 | ") 57 | 58 | (simple-tests prefix-suffix-test 59 | (binding [*print-pprint-dispatch* simple-dispatch 60 | *print-right-margin* 10, *print-miser-width* 10] 61 | (cl-format nil "~<{~;LIST ~@_~W ~@_~W ~@_~W~;}~:>" '(first second third))) 62 | "{LIST\n first\n second\n third}") 63 | 64 | (simple-tests pprint-test 65 | (binding [*print-pprint-dispatch* simple-dispatch] 66 | (write '(defn foo [x y] 67 | (let [result (* x y)] 68 | (if (> result 400) 69 | (cl-format true "That number is too big") 70 | (cl-format true "The result of ~d x ~d is ~d" x y result)))) 71 | :stream nil)) 72 | "(defn 73 | foo 74 | [x y] 75 | (let 76 | [result (* x y)] 77 | (if 78 | (> result 400) 79 | (cl-format true \"That number is too big\") 80 | (cl-format true \"The result of ~d x ~d is ~d\" x y result))))" 81 | 82 | (with-pprint-dispatch code-dispatch 83 | (write '(defn foo [x y] 84 | (let [result (* x y)] 85 | (if (> result 400) 86 | (cl-format true "That number is too big") 87 | (cl-format true "The result of ~d x ~d is ~d" x y result)))) 88 | :stream nil)) 89 | "(defn foo [x y] 90 | (let [result (* x y)] 91 | (if (> result 400) 92 | (cl-format true \"That number is too big\") 93 | (cl-format true \"The result of ~d x ~d is ~d\" x y result))))" 94 | 95 | (binding [*print-pprint-dispatch* simple-dispatch 96 | *print-right-margin* 15] 97 | (write '(fn (cons (car x) (cdr y))) :stream nil)) 98 | "(fn\n (cons\n (car x)\n (cdr y)))" 99 | 100 | (with-pprint-dispatch code-dispatch 101 | (binding [*print-right-margin* 52] 102 | (write 103 | '(add-to-buffer this (make-buffer-blob (str (char c)) nil)) 104 | :stream nil))) 105 | "(add-to-buffer\n this\n (make-buffer-blob (str (char c)) nil))" 106 | ) 107 | 108 | 109 | 110 | (simple-tests pprint-reader-macro-test 111 | (with-pprint-dispatch code-dispatch 112 | (write (read-string "(map #(first %) [[1 2 3] [4 5 6] [7]])") 113 | :stream nil)) 114 | "(map #(first %) [[1 2 3] [4 5 6] [7]])" 115 | 116 | (with-pprint-dispatch code-dispatch 117 | (write (read-string "@@(ref (ref 1))") 118 | :stream nil)) 119 | "@@(ref (ref 1))" 120 | 121 | (with-pprint-dispatch code-dispatch 122 | (write (read-string "'foo") 123 | :stream nil)) 124 | "'foo" 125 | ) 126 | 127 | (defmacro code-block 128 | "Read a string then print it with code-dispatch and succeed if it comes out the same" 129 | [test-name & blocks] 130 | `(simple-tests ~test-name 131 | ~@(apply concat 132 | (for [block blocks] 133 | `[(str/split-lines 134 | (with-out-str 135 | (with-pprint-dispatch code-dispatch 136 | (pprint (read-string ~block))))) 137 | (str/split-lines ~block)])))) 138 | 139 | (code-block code-block-tests 140 | "(defn cl-format 141 | \"An implementation of a Common Lisp compatible format function\" 142 | [stream format-in & args] 143 | (let [compiled-format (if (string? format-in) 144 | (compile-format format-in) 145 | format-in) 146 | navigator (init-navigator args)] 147 | (execute-format stream compiled-format navigator)))" 148 | 149 | "(defn pprint-defn [writer alis] 150 | (if (next alis) 151 | (let [[defn-sym defn-name & stuff] alis 152 | [doc-str stuff] (if (string? (first stuff)) 153 | [(first stuff) (next stuff)] 154 | [nil stuff]) 155 | [attr-map stuff] (if (map? (first stuff)) 156 | [(first stuff) (next stuff)] 157 | [nil stuff])] 158 | (pprint-logical-block 159 | writer 160 | :prefix 161 | \"(\" 162 | :suffix 163 | \")\" 164 | (cl-format true \"~w ~1I~@_~w\" defn-sym defn-name) 165 | (if doc-str (cl-format true \" ~_~w\" doc-str)) 166 | (if attr-map (cl-format true \" ~_~w\" attr-map)) 167 | (cond 168 | (vector? (first stuff)) (single-defn 169 | stuff 170 | (or doc-str attr-map)) 171 | :else (multi-defn stuff (or doc-str attr-map))))) 172 | (pprint-simple-code-list writer alis)))") 173 | 174 | (code-block ns-macro-test 175 | "(ns slam.hound.stitch 176 | (:use [slam.hound.prettify :only [prettify]]))" 177 | 178 | "(ns slam.hound.prettify 179 | \"Format a namespace declaration using pretty print with custom dispatch.\" 180 | (:use [clojure.pprint :only [cl-format code-dispatch formatter-out 181 | pprint pprint-logical-block 182 | pprint-newline with-pprint-dispatch 183 | write-out]]))" 184 | 185 | "(ns autodoc.build-html 186 | \"This is the namespace that builds the HTML pages themselves. 187 | It is implemented with a number of custom enlive templates.\" 188 | {:skip-wiki true, :author \"Tom Faulhaber\"} 189 | (:refer-clojure :exclude [empty complement]) 190 | (:import [java.util.jar JarFile] 191 | [java.io File FileWriter BufferedWriter StringReader 192 | BufferedInputStream BufferedOutputStream 193 | ByteArrayOutputStream FileReader FileInputStream] 194 | [java.util.regex Pattern]) 195 | (:require [clojure.string :as str]) 196 | (:use [net.cgrand.enlive-html :exclude (deftemplate)] 197 | [clojure.java.io :only (as-file file writer)] 198 | [clojure.java.shell :only (sh)] 199 | [clojure.pprint :only (pprint cl-format pprint-ident 200 | pprint-logical-block set-pprint-dispatch 201 | get-pretty-writer fresh-line)] 202 | [clojure.data.json :only (pprint-json)] 203 | [autodoc.collect-info :only (contrib-info)] 204 | [autodoc.params :only (params expand-classpath)]) 205 | (:use clojure.set clojure.java.io clojure.data clojure.java.browse 206 | clojure.inspector clojure.zip clojure.stacktrace))") 207 | 208 | (defn tst-pprint 209 | "A helper function to pprint to a string with a restricted right margin" 210 | [right-margin obj] 211 | (binding [*print-right-margin* right-margin 212 | *print-pretty* true] 213 | (write obj :stream nil))) 214 | 215 | ;;; A bunch of predefined data to print 216 | (def future-filled (future-call (fn [] 100))) 217 | @future-filled 218 | (def future-unfilled (future-call (fn [] (.acquire (java.util.concurrent.Semaphore. 0))))) 219 | (def promise-filled (promise)) 220 | (deliver promise-filled '(first second third)) 221 | (def promise-unfilled (promise)) 222 | (def basic-agent (agent '(first second third))) 223 | (def basic-atom (atom '(first second third))) 224 | (def basic-ref (ref '(first second third))) 225 | (def delay-forced (delay '(first second third))) 226 | (force delay-forced) 227 | (def delay-unforced (delay '(first second third))) 228 | (defrecord pprint-test-rec [a b c]) 229 | 230 | (simple-tests pprint-datastructures-tests 231 | (tst-pprint 20 future-filled) #"#" 232 | (tst-pprint 20 future-unfilled) #"#" 233 | (tst-pprint 20 promise-filled) #"#" 234 | ;; This hangs currently, cause we can't figure out whether a promise is filled 235 | ;;(tst-pprint 20 promise-unfilled) #"#" 236 | (tst-pprint 20 basic-agent) #"#" 237 | (tst-pprint 20 basic-atom) #"#" 238 | (tst-pprint 20 basic-ref) #"#" 239 | (tst-pprint 20 delay-forced) #"#" 240 | ;; Currently no way not to force the delay 241 | ;;(tst-pprint 20 delay-unforced) #"#" 242 | (tst-pprint 20 (pprint-test-rec. 'first 'second 'third)) "{:a first,\n :b second,\n :c third}" 243 | 244 | ;; basic java arrays: fails owing to assembla ticket #346 245 | ;;(tst-pprint 10 (int-array (range 7))) "[0,\n 1,\n 2,\n 3,\n 4,\n 5,\n 6]" 246 | (tst-pprint 15 (reduce conj clojure.lang.PersistentQueue/EMPTY (range 10))) 247 | "<-(0\n 1\n 2\n 3\n 4\n 5\n 6\n 7\n 8\n 9)-<" 248 | ) 249 | 250 | 251 | ;;; Some simple tests of dispatch 252 | 253 | (defmulti 254 | test-dispatch 255 | "A test dispatch method" 256 | {:added "1.2" :arglists '[[object]]} 257 | #(and (seq %) (not (string? %)))) 258 | 259 | (defmethod test-dispatch true [avec] 260 | (pprint-logical-block :prefix "[" :suffix "]" 261 | (loop [aseq (seq avec)] 262 | (when aseq 263 | (write-out (first aseq)) 264 | (when (next aseq) 265 | (.write ^java.io.Writer *out* " ") 266 | (pprint-newline :linear) 267 | (recur (next aseq))))))) 268 | 269 | (defmethod test-dispatch false [aval] (pr aval)) 270 | 271 | (simple-tests dispatch-tests 272 | (with-pprint-dispatch test-dispatch 273 | (with-out-str 274 | (pprint '("hello" "there")))) 275 | "[\"hello\" \"there\"]\n" 276 | ) 277 | 278 | (simple-tests print-length-tests 279 | (binding [*print-length* 1] (with-out-str (pprint '(a b c d e f)))) 280 | "(a ...)\n" 281 | (binding [*print-length* 2] (with-out-str (pprint '(a b c d e f)))) 282 | "(a b ...)\n" 283 | (binding [*print-length* 6] (with-out-str (pprint '(a b c d e f)))) 284 | "(a b c d e f)\n" 285 | (binding [*print-length* 8] (with-out-str (pprint '(a b c d e f)))) 286 | "(a b c d e f)\n" 287 | 288 | (binding [*print-length* 1] (with-out-str (pprint [1 2 3 4 5 6]))) 289 | "[1 ...]\n" 290 | (binding [*print-length* 2] (with-out-str (pprint [1 2 3 4 5 6]))) 291 | "[1 2 ...]\n" 292 | (binding [*print-length* 6] (with-out-str (pprint [1 2 3 4 5 6]))) 293 | "[1 2 3 4 5 6]\n" 294 | (binding [*print-length* 8] (with-out-str (pprint [1 2 3 4 5 6]))) 295 | "[1 2 3 4 5 6]\n" 296 | 297 | (binding [*print-length* 1] (with-out-str (pprint (sorted-set 1 2 3 4 5 6)))) 298 | "#{1 ...}\n" 299 | (binding [*print-length* 2] (with-out-str (pprint (sorted-set 1 2 3 4 5 6)))) 300 | "#{1 2 ...}\n" 301 | (binding [*print-length* 6] (with-out-str (pprint (sorted-set 1 2 3 4 5 6)))) 302 | "#{1 2 3 4 5 6}\n" 303 | (binding [*print-length* 8] (with-out-str (pprint (sorted-set 1 2 3 4 5 6)))) 304 | "#{1 2 3 4 5 6}\n" 305 | 306 | (binding [*print-length* 1] (with-out-str (pprint (sorted-map 1 2, 3 4, 5 6, 7 8, 9 10, 11 12)))) 307 | "{1 2, ...}\n" 308 | (binding [*print-length* 2] (with-out-str (pprint (sorted-map 1 2, 3 4, 5 6, 7 8, 9 10, 11 12)))) 309 | "{1 2, 3 4, ...}\n" 310 | (binding [*print-length* 6] (with-out-str (pprint (sorted-map 1 2, 3 4, 5 6, 7 8, 9 10, 11 12)))) 311 | "{1 2, 3 4, 5 6, 7 8, 9 10, 11 12}\n" 312 | (binding [*print-length* 8] (with-out-str (pprint (sorted-map 1 2, 3 4, 5 6, 7 8, 9 10, 11 12)))) 313 | "{1 2, 3 4, 5 6, 7 8, 9 10, 11 12}\n" 314 | 315 | 316 | (binding [*print-length* 1] (with-out-str (pprint (int-array [1 2 3 4 5 6])))) 317 | "[1, ...]\n" 318 | (binding [*print-length* 2] (with-out-str (pprint (int-array [1 2 3 4 5 6])))) 319 | "[1, 2, ...]\n" 320 | (binding [*print-length* 6] (with-out-str (pprint (int-array [1 2 3 4 5 6])))) 321 | "[1, 2, 3, 4, 5, 6]\n" 322 | (binding [*print-length* 8] (with-out-str (pprint (int-array [1 2 3 4 5 6])))) 323 | "[1, 2, 3, 4, 5, 6]\n" 324 | ) 325 | 326 | (defn- flush-alerting-writer 327 | [o] 328 | (let [flush-count-atom (atom 0)] 329 | [ 330 | (proxy [java.io.BufferedWriter] [o] 331 | (flush [] 332 | (proxy-super flush) 333 | (swap! flush-count-atom inc))) 334 | flush-count-atom])) 335 | 336 | (deftest test-flush-underlying-prn 337 | [] 338 | (let [[out flush-count-atom] (flush-alerting-writer (java.io.StringWriter.))] 339 | (binding [*out* out 340 | *flush-on-newline* true] 341 | (prn (range 50)) 342 | (prn (range 50))) 343 | (is (= @flush-count-atom 2) "println flushes on newline"))) 344 | 345 | (deftest test-flush-underlying-pprint 346 | [] 347 | (let [[out flush-count-atom] (flush-alerting-writer (java.io.StringWriter.))] 348 | (binding [*out* out 349 | *flush-on-newline* true] 350 | (pprint (range 50)) 351 | (pprint (range 50))) 352 | (is (= @flush-count-atom 2) "pprint flushes on newline"))) 353 | 354 | (deftest test-noflush-underlying-prn 355 | [] 356 | (let [[out flush-count-atom] (flush-alerting-writer (java.io.StringWriter.))] 357 | (binding [*out* out 358 | *flush-on-newline* nil] 359 | (prn (range 50)) 360 | (prn (range 50))) 361 | (is (= @flush-count-atom 0) "println flushes on newline"))) 362 | 363 | (deftest test-noflush-underlying-pprint 364 | [] 365 | (let [[out flush-count-atom] (flush-alerting-writer (java.io.StringWriter.))] 366 | (binding [*out* out 367 | *flush-on-newline* nil] 368 | (pprint (range 50)) 369 | (pprint (range 50))) 370 | (is (= @flush-count-atom 0) "pprint flushes on newline"))) 371 | 372 | -------------------------------------------------------------------------------- /test/cljs/cljs/pprint_test.clj: -------------------------------------------------------------------------------- 1 | (ns cljs.pprint-test 2 | (:require [cljs.test :refer [deftest is]])) 3 | 4 | (defmacro simple-tests [name & test-pairs] 5 | `(deftest ~name 6 | ~@(for [[x y] (partition 2 test-pairs)] 7 | `(cond 8 | (= js/RegExp (type ~y)) (is (.exec ~y ~x)) 9 | (= js/String (type ~y)) (is (= ~x ~y)) 10 | :else (is (= ~x ~y)))))) 11 | 12 | (defmacro code-block 13 | "Read a string then print it with code-dispatch and succeed if it comes out the same" 14 | [test-name & blocks] 15 | `(simple-tests ~test-name 16 | ~@(apply concat 17 | (for [block blocks] 18 | `[(clojure.string/split-lines 19 | (with-out-str 20 | (cljs.pprint/with-pprint-dispatch cljs.pprint/code-dispatch 21 | (cljs.pprint/pprint (cljs.reader/read-string ~block))))) 22 | (clojure.string/split-lines ~block)])))) 23 | 24 | --------------------------------------------------------------------------------