-
Notifications
You must be signed in to change notification settings - Fork 47
/
core.cljc
1528 lines (1444 loc) · 68.7 KB
/
core.cljc
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
;!zprint {:style :require-justify}
(ns zprint.core
#?@(:cljs [[:require-macros
[zprint.macros :refer [dbg dbg-pr dbg-form dbg-print]]]])
(:require
#?@(:clj [[zprint.macros :refer [dbg-pr dbg dbg-form dbg-print]]])
clojure.string
#?@(:cljs [[cljs.reader :refer [read-string]]])
#?@(:clj [[clojure.java.io :as io] [clojure.repl :refer [source-fn]]])
[zprint.zprint :as zprint
:refer [fzprint line-count max-width line-widths
expand-tabs zcolor-map
determine-ending-split-lines]]
[zprint.finish :refer [cvec-to-style-vec compress-style no-style-map
color-comp-vec handle-lines]]
[zprint.comment :refer [fzprint-inline-comments fzprint-wrap-comments
fzprint-align-inline-comments blanks]]
[zprint.config :as config
:refer [add-calculated-options config-set-options!
get-options config-configure-all! reset-options!
help-str get-explained-options
get-explained-set-options
get-explained-all-options get-default-options
validate-options apply-style perform-remove
no-color-map merge-deep sci-load-string
config-and-validate]]
[zprint.zutil :refer [zmap-all zcomment? whitespace? znewline?
find-root-and-path-nw]]
[zprint.sutil]
[zprint.focus :refer [range-ssv]]
[zprint.range :refer [expand-range-to-top-level split-out-range
reassemble-range]]
[rewrite-clj.parser :as p]
[rewrite-clj.zip :as z
:refer [edn* string]]
#_[clojure.spec.alpha :as s])
#?@(:clj ((:import #?(:bb []
:clj (java.net URL URLConnection))
#?(:bb []
:clj (java.util.concurrent Executors))
(java.io File)
(java.util Date)))))
;;
;; zprint
;;
;; A complete pretty printing package for Clojure.
;;
;; Prints both structures and code at the repl, and code in files.
;; Highly configurable, doesn't lose comments. Completely ignores
;; any incoming whitespace and newlines -- produces its own idea of
;; the best output possible for a given output width.
;;
;; There are a number of namespaces:
;;
;; core user visible API
;; config configuration processing and storage
;; zprint actual pretty printing logic, relies on zutil or sutil
;; zutil zipper manipulation routines
;; sutil sexpression manipulation routines
;; focus add focus to output of zprint
;; finish process result of zprint into desired type
;; ansi do coloring for ansi terminal output
;; repl contains a bunch test cases for zprint development
;;
;; Basic code flow:
;;
;; The user visible API in zprint.core determines whether the thing
;; to be pretty printed is an sexpression which should be pretty
;; printed directly, or a string which should be parsed into a
;; zipper and then printed (based on :parse-string?).
;; It also handles some exceptional calls directly (e.g.,
;; (czprint nil :describe)), but generally calls
;; zprint.zprint/fzprint* to do the pretty printing. The options
;; map has been properly configured to use the routines for
;; sexpressions (in sutil) or for zippers (in zutil).
;;
;; zprint.zprint/fzprint* is the routine that handles pretty
;; printing anything -- it dispatches to a variety of fzprint-
;; routines, each one handling a different type of structure.
;; Each of the fzprint- routines takes an option map, which contains
;; not only the configured options and proper utility routines
;; (configured by zprint.core), but also additional information useful
;; during the run-time processing of the structure.
;;
;; zprint/fzprint* returns a str-style-vec, which is a structure
;; like this:
;;
;; [[<string> <color> <type>][<string> <color> <type>] ...]
;;
;; The strings are the actual things to be output, the color is the
;; color in which to output them (if using color), and the type is
;; the type of the information in the string, which is one of:
;;
;; :whitespace blanks and newlines
;; :element actual strings containing output
;; :left, :right signals left or right end of a collection
;;
;; This information is processed into useable output by the
;; zprint.core functions by calling functions in zprint.finish and
;; zprint.ansi.
;;
;; zprint.focus is used when calling the zprint.core functions with
;; a zipper, and will assist the user in creating output which shows
;; a focus on some internal structure inside a containing structure.
;; Presently, the API for this is not documented.
;;
;;
;;
;; Clean up the API a bit by putting all of the public functions
;; in zprint.core
;;
(def ^:dynamic ^:no-doc *cache-path*
#?(:bb nil
:clj (str (System/getProperty "user.home") File/separator ".zprint")
:cljs nil))
(defn set-options!
"There is an internal options-map containing default values which is
configured from ~/.zprintrc when zprint is first used. set-options!
is used to alter the internal options-map by specifying individual
options-map values that will be merged into the internal options-map.
Typically, it is called with only new-options, an options map. If
you add a doc-str, that will show up when the internal options map
is displayed with (czprint nil :explain). The argument op-options
is an options map that is only examined if the call to set-options!
is the first use of the zprint library. If it is, operational options
are examined in the op-options map to see where to find formatting
options. Operational options are those such as cwd-zprintrc? and
search-config?."
([new-options doc-str op-options]
(do (config-set-options! new-options doc-str op-options) nil))
([new-options doc-str] (do (config-set-options! new-options doc-str) nil))
([new-options] (do (config-set-options! new-options) nil)))
; Default [:cache :location]
(def ^:dynamic ^:no-doc *default-cache-loc* ".")
; Default [:cache :directory]
(def ^:dynamic ^:no-doc *default-cache-dir* ".zprint")
; Default [:url :cache-dir]
(def ^:dynamic ^:no-doc *default-url-cache* "urlcache")
; Default [:url :cache-secs]
(def ^:dynamic ^:no-doc *default-url-cache-secs* 300)
(defn ^:no-doc load-options!
"Loads options from url, expecting an edn options map that will be passed
to set-options! Valid options will be cached in
(str (:cache-loc (:cache options))
File/separator
(:cache-dir (:cache options))
File/separator
(:url (:cache-dir (:cache options))))
for (:cache-secs (:url options)) or 5 minutes if :cache-secs is nil.
If [:cache :location] contains a \".\", it is considered a Java property,
else it is considered an environment variable. In either case,
it is looked up.
Invalid options will throw an Exception.
HTTP urls will have the Cache-Control max-age parameter respected,
falling back to the Expires header if set."
[options url]
#?(:bb nil
:clj
(let [^URL url (if (instance? URL url) url (URL. url))
host (if (= "" (.getHost url)) "nohost" (.getHost url))
url-as-filename (str host "_" (hash (str url)))
cache-loc (or (:location (:cache options)) "")
; If we have no cache-loc, make it the current directory
cache-loc (if (empty? cache-loc)
*default-cache-loc*
; If the cache-loc includes a ".", then treat it
; as a Java system property, else an environment
; variable.
(if (clojure.string/includes? cache-loc ".")
(System/getProperty cache-loc)
(System/getenv cache-loc)))
; Default cache-dir to .zprint
cache-dir (or (:directory (:cache options)) *default-cache-dir*)
cache-path (str cache-loc File/separator cache-dir)
; Default urldir to "urlcache"
urldir (or (:cache-dir (:url options)) *default-url-cache*)
cache-secs (or (:cache-secs (:url options))
*default-url-cache-secs*)
cache (if (:cache-path (:url options))
(io/file (:cache-path (:url options)))
(io/file (str cache-path File/separator urldir)
url-as-filename))
cache-item (if (and (.exists cache) (not (zero? (.length cache))))
(try (-> (slurp cache)
(sci-load-string)
#_(clojure.edn/read-string))
(catch Exception e (.delete cache) nil)))
active-cache? (and cache-item
(> (:expires cache-item)
(System/currentTimeMillis)))]
#_(prn "cache items:"
"\noptions:" options
"\ncache-loc:" cache-loc
"\ncache-dir:" cache-dir
"\ncache-path:" cache-path
"\nurl-dir:" urldir
"\ncache-secs:" cache-secs
"\ncache:" cache
"\ncache-items:" cache-item
"\nactive-cache?:" active-cache?)
(if active-cache?
;1> cached, non expired version of url used
(set-options! (:options cache-item) (str "cached options from " url))
(try
(let [^URLConnection remote-conn (doto (.openConnection url)
(.setConnectTimeout 1000)
(.connect))
remote-opts (some-> (slurp (.getInputStream remote-conn))
(sci-load-string)
#_(clojure.edn/read-string))]
(if remote-opts
(do
;2> no valid cache, remote used, async best-effort cache
(set-options! remote-opts (str "options from " url))
(.. (Executors/newSingleThreadExecutor)
(submit
(reify
Runnable
(run [this]
(try
(io/make-parents cache)
(let [cc (.getHeaderField remote-conn
"Cache-Control")
[_ max-age]
(if cc
(re-matches
#"(?i).*?max-age\s*=\s*(\d+)"
cc))
cache-expiry
(if max-age
(+ (System/currentTimeMillis)
(* 1000 (Long/parseLong max-age)))
(let [expires (.getExpiration
remote-conn)]
(if (and expires
(not (zero? expires)))
expires
(+ (System/currentTimeMillis)
(* 1000 cache-secs)))))]
(spit cache
(pr-str {:expires cache-expiry,
:options remote-opts})))
(catch Exception e
(.println System/err
(format
"WARN: cache failed for %s: %s"
url
(.getMessage e))))))))
(get)))
;3> no cache, blank remote
(throw (Exception. "ERROR: retrieving config from %s" url))))
(catch Exception e
(if cache-item
(do
;4> expired cache but remote failed, use cache
(set-options! (:options cache-item)
(str "cached, but expired, options from " url))
(.println
System/err
(format
"WARN: using expired cache config for %s after error: %s"
url
(.getMessage e))))
(throw ;5> no cache, failed remote
(Exception. (format "ERROR: retrieving config from %s: %s"
url
(.getMessage e)))))))))
:cljs nil))
(defn configure-all!
"Do external configuration regardless of whether or not it already
been done, replacing any existing configuration. Returns nil if successful,
a vector of errors if not."
[]
(config-configure-all!))
;;
;; # Zipper determination and handling
;;
(defn ^:no-doc rewrite-clj-zipper?
"Is this a rewrite-clj zipper node? A surprisingly hard thing to
determine, actually."
[z]
(when (and (coll? z)
(let [type-str (pr-str (type (first z)))]
(and (> (count type-str) 16)
(= "rewrite_clj.node" (subs type-str 0 16)))))
; (= "rewrite_clj.node" (subs (pr-str (type (first z))) 0 16)))
z))
(defn ^:no-doc zipper?
"Is this a zipper?"
[z]
(when (coll? z) (or (rewrite-clj-zipper? z) (:tag (first z)))))
(defn ^:no-doc get-zipper
"If it is a zipper or a string, return a zipper, else return nil.
Always trims whitespace (including nl) off of strings before parsing!
Returns [zloc line-ending-str], with line-ending-str nil if x was a
zipper."
[options x]
(if (string? x)
(let [[line-ending lines] (determine-ending-split-lines x)
lines (if (:expand? (:tab options))
(map (partial expand-tabs (:size (:tab options))) lines)
lines)
; Glue lines back together with \n line ending, to work around
; rewrite-clj bug with \r\n endings on comments. Otherwise,
; the rewrite-clj parse would "convert" them all to \n for us,
; which is really what we need anyway.
;
; On the ohter hand, breaking it into lines to do the tab expansion
; is considerably faster than just doing it on the whole file when
; a tab is found.
x (clojure.string/join "\n" lines)
n (p/parse-string (clojure.string/trim x))]
(when n [(edn* n) line-ending]))
(when (zipper? x) [x nil])))
;;
;; # Internal version of zprint for debugging output
;;
(declare zprint-str-internal)
(defn ^:no-doc dzprint-zipper
"If we are running in zipper mode, do an internal version of zprint
on a structure."
[options coll]
(let [coll-str (pr-str coll)]
(try (str "\n"
(zprint-str-internal (merge-deep {:parse-string? true} options)
coll-str))
; If it doesn't work for some reason, just output the string
(catch #?(:clj Exception
:cljs :default)
e
coll-str))))
(defn ^:no-doc dzprint-sexpr
"If we are running in zipper mode, do an internal version of zprint
on a structure."
[options coll]
(try (str "\n" (zprint-str-internal options coll))
; If it doesn't work for some reason, just output the string
(catch #?(:clj Exception
:cljs :default)
e
(pr-str coll))))
;;
;; # Interface into zprint.zprint namespace
;;
;!zprint {:format :next :vector {:wrap? false}}
(defn ^:no-doc fzprint-style
"Do a basic zprint and output the style vector and the options used for
further processing: [<style-vec> options line-ending]"
[coll options]
(let [[input options line-ending]
(cond (:zipper? options)
#?(:clj (if (zipper? coll)
[coll options nil]
(throw (Exception. (str
"Collection is not a zipper"
" yet :zipper? specified!"))))
:cljs [coll options nil])
(:parse-string? options)
(if (string? coll)
(let [[form line-end] (get-zipper options coll)]
[form options line-end])
(throw (#?(:clj Exception.
:cljs js/Error.)
(str "Collection is not a string yet"
" :parse-string? specified!"))))
(:zloc? (:focus (:output options)))
; We have a zloc which we want to display with
; focus. First, we have to find the root and path
; of the zloc.
(let [[root path] (find-root-and-path-nw coll)]
[root (assoc-in options [:output :focus :path] path) nil])
:else [nil options nil])
z-type (if input :zipper :sexpr)
dzprint (if (= z-type :zipper) dzprint-zipper dzprint-sexpr)
input (or input coll)]
(cond (nil? input)
[[["nil" (zcolor-map options :nil) :element]] options line-ending]
(:drop? options) [[["" :none]] options line-ending]
;(if (or (nil? input) (:drop? options))
; (and (:spaces? options)
; (:file? options)
; (or
; ; we ar getting rid of just spaces between expr
; (= (:left-space (:parse options)) :drop)
; ; we are getting rid of all whitespace between expr
; (:interpose (:parse options)))))
;
;[[["nil" (zcolor-map options :nil) :element]] options]
:else
(let [options (assoc options
:ztype z-type
:dzprint dzprint)
fzprint-fn (partial fzprint
options
(if (and (:file? options)
(= (:left-space (:parse options))
:keep))
(or (:indent options) 0)
0)
input)]
#_(def coreopt options)
[(if (= z-type :zipper)
(zprint.zutil/zredef-call fzprint-fn)
(zprint.sutil/sredef-call fzprint-fn))
options
line-ending]))))
#?(:clj (declare get-docstring-spec))
(defn ^:no-doc process-rest-options
"Take some internal-options and the & rest of a zprint/czprint
call and figure out the options and width and all of that, but
stop short of integrating these values into the existing options
that show up with (get-options). Note that internal-options MUST
NOT be a full options-map. It needs to be just the options that
have been requested for this invocation. Does auto-width if that
is requested, and determines if there are 'special-options', which
may short circuit the other options processing.
Returns [special-option rest-options]"
[internal-options [width-or-options options]]
#_(println "process-rest-options: internal-options:" internal-options
"width-or-options:" width-or-options
"options:" options)
#_(def prio internal-options)
#_(def prwoo width-or-options)
#_(def pro options)
(cond
(= width-or-options :default) [:default (get-default-options)]
:else
(let [[width-or-options special-option]
(if (#{:explain :explain-set :support :explain-justified :help}
width-or-options)
[nil width-or-options]
[width-or-options nil])
configure-errors (when-not (:configured? (get-options))
(configure-all!))
width (when (number? width-or-options) width-or-options)
rest-options (cond (and width (map? options)) options
(map? width-or-options) width-or-options)
width-map (if width {:width width} {})
; new-options (merge-deep rest-options width-map
; internal-options)
new-options (merge-deep internal-options rest-options width-map)
auto-width
(when (and (not width)
; check both new-options and already
; configured ones
(:auto-width? new-options
(:auto-width? (get-options))))
(let [terminal-width-fn
#?(:bb nil
:clj (resolve 'table.width/detect-terminal-width)
:cljs nil)
actual-width (when terminal-width-fn (terminal-width-fn))]
(when (number? actual-width) {:width actual-width})))
new-options
(if auto-width (merge-deep new-options auto-width) new-options)
#_(def nopt new-options)]
[special-option new-options])))
(defn ^:no-doc determine-options
"Take some internal-options and the & rest of a zprint/czprint
call and figure out the options and width and all of that. Note
that internal-options MUST NOT be a full options-map. It needs
to be just the options that have been requested for this invocation.
Does auto-width if that is requested, and determines if there are
'special-options', which may short circuit the other options
processing. Returns [special-option actual-options]"
[rest-options]
#_(println "\n\ndetermine-options:" rest-options
"\n\n" (zprint.config/get-stack-trace))
(let [; Do what config-and-validate does, minus the doc-map
configure-errors (when-not (:configured? (get-options))
(configure-all!))
[actual-options _ errors] (config-and-validate "determine-options"
nil
(get-options)
rest-options)
combined-errors
(str (when configure-errors
(str "Global configuration errors: " configure-errors))
(when errors (str "Option errors in this call: " errors)))]
(if (not (empty? combined-errors))
(throw (#?(:clj Exception.
:cljs js/Error.)
combined-errors))
#_(def dout actual-options)
actual-options)))
;;
;; # Fundemental interface for fzprint-style, does configuration
;;
(defn ^:no-doc zprint*
"Basic setup for fzprint call, used by all top level fns. Third
argument can be either a number or a map, and if the third is a
number, the fourth (if any) must be a map. The internal-options
is either an empty map or {:parse-string? true} for the -fn
functions, and cannot be overridden by an options argument. Returns
a vector with the style-vec and the options used:
[<style-vec> options line-ending]"
[coll special-option actual-options]
(if special-option
(case special-option
:explain (fzprint-style (get-explained-options)
; If we are doing :key-order, we need
; add-calculated-options
(add-calculated-options
(merge-deep (get-default-options)
actual-options
{:map {:key-order [:doc],
:key-color {:doc :blue},
:key-value-color
{:doc {:string
:green}}}})))
:explain-set (fzprint-style (get-explained-set-options)
; If we are doing :key-order, we need
; add-calculated-options
(add-calculated-options
(merge-deep (get-default-options)
actual-options
{:map {:key-order [:doc],
:key-color {:doc :blue},
:key-value-color
{:doc {:string
:green}}}})))
:explain-justified
(fzprint-style
(get-explained-options)
; If we are doing :key-order, we need add-calculated-options
(add-calculated-options
(merge-deep (get-default-options)
actual-options
{:map {:key-order [:doc],
:key-color {:doc :blue},
:key-value-color {:doc {:string :green}},
:justify? true,
:justify {:max-variance 20}}})))
:support (fzprint-style (get-explained-all-options)
(merge-deep (get-default-options) actual-options))
:help (println help-str)
(println (str "Unknown keyword option: " special-option)))
(fzprint-style coll
(if-let [fn-name (:fn-name actual-options)]
(if (:docstring? (:spec actual-options))
#?(:bb actual-options
:clj (assoc-in actual-options
[:spec :value]
(get-docstring-spec actual-options fn-name))
:cljs actual-options)
actual-options)
actual-options))))
(declare process-multiple-forms)
(defn ^:no-doc parse-string-all-options
"Handle options for :parse-string-all?, by removing
:parse-string-all? and changing the default for
:parse {:interpose } to be true instead of nil."
[options]
(-> (if (nil? (:interpose (:parse options)))
(assoc-in options [:parse :interpose] true)
options)
(dissoc :parse-string-all?)
(assoc :trim-comments? true)))
;;
;; # API Support
;;
;; Note that :parse-string-all? support is related to the
;; zprint-file file parsing and printing support, but that
;; they are not the same. The :parse-string-all? support is
;; designed for taking in a string and doing something useful
;; with it if it has multiple forms in it, while the file support
;; is focused on doing a whole file. As such, the :interpose
;; support for :parse-string-all? isn't going to play well with
;; the file support. The :left-space :keep|:drop support is
;; designed for the file support.
;;
;; That said, they both go through the process-multiple-forms
;; function, so that we now have a nice way to test that support.
(defn ^:no-doc range-vec
"Select the elements from start to end from a vector."
[v [start end]]
(take (- end start) (drop start v)))
(defn ^:no-doc remove-loc
"If this is a :newline, :indent, :whitespace, or :right, trim off the
4th thing."
[tuple]
(let [[s color element] tuple]
(if (or (= element :newline)
(= element :indent)
(= element :whitespace)
(= element :right))
[s color element]
tuple)))
(defn ^:no-doc remove-newline-indent-locs ; i132
"Remove the debugging information on :indent and :newline style-vec
elements when doing :return-cvec? true."
[cvec]
(mapv remove-loc cvec))
(defn ^:no-doc any-respect?
"If any of :respect-nl?, :respect-bl?, or :indent-only? are set, return
true."
[caller options]
(let [callers-options (caller options)]
(or (:respect-nl? callers-options)
(:respect-bl? callers-options)
(:indent-only? callers-options))))
(defn ^:no-doc any-respect-at-all?
"Look throught the options, and see if any of :respect-nl?, :respect-bl?
or :indent-only are enabled for anything. Return false if none are enabled,
truthy if any are."
[options]
(or (any-respect? :list options)
(any-respect? :vector options)
(any-respect? :set options)
(any-respect? :map options)))
(defn ^:no-doc find-eol-blanks
"Given a str-style-vec, find all of the places where the end of a line
has blanks. Output the tuples that have that and the ones that
follow. If no-respect? is truthy, then only do this if no :respect-nl,
:respect-bl, or indent-only are set."
[options ssv coll no-respect?]
(when (cond (string? coll) (not (clojure.string/blank? coll))
(zipper? coll) (not (clojure.string/blank? (rewrite-clj.zip/string
coll)))
:else nil)
(if (or (not no-respect?) (not (any-respect-at-all? options)))
(loop [style-vec ssv
previous-ends-w-blanks? nil
previous-tuple nil
out []]
(if-not (first style-vec)
(if previous-ends-w-blanks? (conj out previous-tuple) out)
(let [[s _ e :as tuple] (first style-vec)
add-previous-to-out? (and (or (= e :indent) (= e :newline))
previous-ends-w-blanks?)
ends-w-blanks? (clojure.string/ends-with? s " ")]
(recur
(next style-vec)
ends-w-blanks?
tuple
(if add-previous-to-out? (conj out previous-tuple) out))))))))
(defn ^:no-doc real-le
"Look at a single element in a style-vec string, and if the string at
first is itself a string, then if the length is over
:output :real-le-length, then replace any escaped line endings
with 'real' line endings."
[real-le-length [s :as element]]
#_(prn "real-le real-le-length" real-le-length " s:" s " element:" element)
(if (and (>= (count s) real-le-length) (clojure.string/starts-with? s "\""))
(do #_(println "real-le ++++++++++")
; Replace the string with one where line endings become 'real'
(assoc element
0 (-> s
(clojure.string/replace "\\n" "\n")
(clojure.string/replace "\\r\\n" "\r\n")
(clojure.string/replace "\\r" "\r"))))
element))
(defn ^:no-doc zprint-str-internal
"Take a zipper or string and pretty print with fzprint,
output a str. Key :color? is false by default, and should
be set to true in internal-options to make things colored.
Special processing for :parse-string-all?, with
not only a different code path, but a different default for
:parse {:interpose nil} to {:interpose true}"
[internal-options coll & rest]
(let [[special-option rest-options] (process-rest-options internal-options
rest)]
#_(println "special-option:" special-option "rest-options:" rest-options)
(dbg rest-options "zprint-str-internal VVVVVVVVVVVVVVVV")
(if (:parse-string-all? rest-options)
(if (string? coll)
(let [[line-ending lines] (determine-ending-split-lines coll)
current-options (merge-deep (get-options) rest-options)
lines (if (:expand? (:tab current-options))
(map (partial expand-tabs (:size (:tab current-options)))
lines)
lines)
; Glue lines back together with \n line ending, to work around
; rewrite-clj bug with \r\n endings on comments. Otherwise,
; the rewrite-clj parse would "convert" them all to \n for us,
; which is really what we need anyway.
;
; On the ohter hand, breaking it into lines to do the tab
; expansion
; is considerably faster than just doing it on the whole file when
; a tab is found.
coll (clojure.string/join "\n" lines)
result (process-multiple-forms (parse-string-all-options
rest-options)
zprint-str-internal
":parse-string-all? call"
(edn* (p/parse-string-all coll)))
#_(def pmr-result result)
str-w-line-endings
(if (or (nil? line-ending) (= line-ending "\n"))
result
(clojure.string/replace result "\n" line-ending))]
(dbg rest-options "zprint-str-internal ^^^ pmf ^^^ pmf ^^^ pmf ^^^")
str-w-line-endings)
(throw (#?(:clj Exception.
:cljs js/Error.)
(str ":parse-string-all? requires a string!"))))
(let [actual-options (determine-options rest-options)
[cvec options line-ending]
(zprint* coll special-option actual-options)
#_(println "special-option:" special-option
"actual-options:" (apply sorted-map
(flatten (seq actual-options)))
"\n\n\noptions:" (apply sorted-map
(flatten (seq options))))
#_(def aopt actual-options)
cvec-wo-empty cvec
#_(def cvwoe cvec-wo-empty)
focus-vec (if-let [path (:path (:focus (:output options)))]
(range-ssv cvec-wo-empty path))
#_(println "focus-vec:" focus-vec)
accept-vec (handle-lines options cvec-wo-empty focus-vec)
#_(println "accept-vec:" accept-vec)
#_(def av accept-vec)
#_(println "elide:" (:elide (:output options)))
eol-blanks (when (:test-for-eol-blanks? options)
(find-eol-blanks options cvec-wo-empty coll nil))
eol-str (when (not (empty? eol-blanks))
(str "======= eol-blanks: " eol-blanks))
inline-style-vec (if (:inline? (:comment options))
(fzprint-inline-comments options cvec-wo-empty)
cvec-wo-empty)
#_(def ssvi inline-style-vec)
inline-style-vec (if (:inline? (:comment options))
(fzprint-align-inline-comments options
inline-style-vec)
inline-style-vec)
#_(def ssvia inline-style-vec)
str-style-vec (cvec-to-style-vec {:style-map no-style-map,
:elide (:elide (:output options))}
inline-style-vec
#_cvec-wo-empty
focus-vec
accept-vec)
#_(def ssvx str-style-vec)
wrapped-style-vec (if (:wrap? (:comment options))
(fzprint-wrap-comments options str-style-vec)
str-style-vec)
#_(def ssvy wrapped-style-vec)
; wrapped-style-vec is still a full style vec,
; with individual elements in it
wrapped-style-vec
(if (:real-le? (:output options))
(mapv (partial real-le (:real-le-length (:output options)))
wrapped-style-vec)
wrapped-style-vec)
comp-style (compress-style wrapped-style-vec)
#_(def cps comp-style)
; don't do extra processing unless we really need it
#_(def fcs (mapv first comp-style))
#_(def le line-ending)
color-style (if (or accept-vec focus-vec (:color? options))
(color-comp-vec comp-style)
(apply str (mapv first comp-style)))
#_(def cs color-style)
str-w-line-endings
(if (or (nil? line-ending) (= line-ending "\n"))
color-style
(clojure.string/replace color-style "\n" line-ending))]
(dbg rest-options "zprint-str-internal ^^^^^^^^^^^^^^^^^^")
(if eol-str
eol-str
(if (:return-cvec? options)
(remove-newline-indent-locs cvec) ; i132
str-w-line-endings))))))
(defn ^:no-doc get-fn-source
"Call source-fn, and if it isn't there throw an exception."
[fn-name]
(or #?(:clj (try (source-fn fn-name) (catch Exception e nil)))
(throw (#?(:clj Exception.
:cljs js/Error.)
(str "No definition found for a function named: " fn-name)))))
;;
;; # User level printing functions
;;
;; (*zprint <to-print> <width> <options-map>)
;;
;; zprint pretty print to *out*
;; czprint pretty print to *out* with ansi colors
;;
;; zprint-str pretty print to string
;; czprint-str pretty print to string with ansi colors
;;
;; options:
;;
;; See config.clj
;;
(defn zprint-str
"Take coll, a Clojure data structure or a string containing Clojure code or
data, format it readably, and output a str. Additional optional arguments:
(zprint-str coll <numeric-width>)
(zprint-str coll <numeric-width> <options-map>)
(zprint-str coll <options-map>)
If coll is a string containing Clojure source:
(zprint-str coll {:parse-string? true})
(zprint nil :help) ; for more information
(zprint nil :explain) ; to see the current options-map"
{:doc/format :markdown}
[coll & rest]
(apply zprint-str-internal {} coll rest))
(defn czprint-str
"Take coll, a Clojure data structure or a string containing Clojure code or
data, format it readably, and output a str containing ANSI escapes to
syntax color the output. Additional optional arguments:
(czprint-str coll <numeric-width>)
(czprint-str coll <numeric-width> <options-map>)
(czprint-str coll <options-map>)
If coll is a string containing Clojure source:
(czprint-str coll {:parse-string? true})
(czprint nil :help) ; for more information
(czprint nil :explain) ; to see the current options-map"
{:doc/format :markdown}
[coll & rest]
(apply zprint-str-internal {:color? true} coll rest))
(defn zprint
"Take coll, a Clojure data structure or a string containing Clojure code or
data, format it readably, and output to stdout. Additional optional
arguments:
(zprint coll <numeric-width>)
(zprint coll <numeric-width> <options-map>)
(zprint coll <options-map>)
If coll is a string containing Clojure source::
(zprint coll {:parse-string? true})
(zprint nil :help) ; for more information
(zprint nil :explain) ; to see the current options-map"
{:doc/format :markdown}
[coll & rest]
(println (apply zprint-str-internal {} coll rest)))
(defn czprint
"Take coll, a Clojure data structure or a string containing Clojure code or
data, format it readably, and produce output to stdout containing ANSI
escapes to syntax color the output. Optional arguments:
(czprint coll <numeric-width>)
(czprint coll <numeric-width> <options-map>)
(czprint coll <options-map>)
If coll is a string containing Clojure source:
(czprint coll {:parse-string? true})
(czprint nil :help) ; for more information
(czprint nil :explain) ; to see the current options-map"
{:doc/format :markdown}
[coll & rest]
(println (apply zprint-str-internal {:color? true} coll rest)))
#?(:clj
(defmacro zprint-fn-str
"Given a function name, fn-name, retrieve the source for it,
and return a string with the source formatted in a highly readable
manner. Appends any available specs to the end of the docstring.
Optional arguments:
(zprint-fn-str fn-name <numeric-width>)
(zprint-fn-str fn-name <numeric-width> <options-map>)
(zprint-fn-str fn-name <options-map>)
(zprint nil :help) ; for more information
(zprint nil :explain) ; to see the current options-map "
{:doc/format :markdown}
[fn-name & rest]
`(apply zprint-str-internal
{:parse-string? true, :fn-name '~fn-name}
(get-fn-source '~fn-name)
~@rest
[])))
#?(:clj
(defmacro czprint-fn-str
"Given a function name, fn-name, retrieve the source for it,
and return a string with the source formatted in a highly readable
manner, including ANSI escape sequences to syntax color the output.
Appends any available specs to the end of the docstring.
Optional arguments:
(czprint-fn-str fn-name <numeric-width>)
(czprint-fn-str fn-name <numeric-width> <options-map>)
(czprint-fn-str fn-name <options-map>)
(czprint nil :help) ; for more information
(czprint nil :explain) ; to see the current options-map"
{:doc/format :markdown}
[fn-name & rest]
`(apply zprint-str-internal
{:parse-string? true, :color? true, :fn-name '~fn-name}
(get-fn-source '~fn-name)
~@rest
[])))
#?(:clj
(defmacro zprint-fn
"Given a function name, fn-name, retrieve the source for it,
and output to stdout the source formatted in a highly readable
manner. Appends any available specs to the end of the docstring.
Optional arguments:
(zprint-fn fn-name <numeric-width>)
(zprint-fn fn-name <numeric-width> <options-map>)
(zprint-fn fn-name <options-map>)
(zprint nil :help) ; for more information
(zprint nil :explain) ; to see the current options-map"
{:doc/format :markdown}
[fn-name & rest]
`(println (apply zprint-str-internal
{:parse-string? true, :fn-name '~fn-name}
(get-fn-source '~fn-name)
~@rest
[]))))
#?(:clj
(defmacro czprint-fn
"Given a function name, fn-name, retrieve the source for it,
and output to stdout the source formatted in a highly readable
manner. Includes ANSI escape sequences to provide syntax coloring,
and appends any available specs to the end of the docstring.
Optional arguments:
(czprint-fn fn-name <numeric-width>)
(czprint-fn fn-name <numeric-width> <options-map>)
(czprint-fn fn-name <options-map>)
(czprint nil :help) ; for more information
(czprint nil :explain) ; to see the current options-map"
{:doc/format :markdown}
[fn-name & rest]
`(println (apply zprint-str-internal
{:parse-string? true, :color? true, :fn-name '~fn-name}
(get-fn-source '~fn-name)
~@rest
[]))))
;;
;; # File operations
;;
;;
;; ## Parse a comment to see if it has an options map in it
;;
(defn ^:no-doc get-options-from-comment
"s is string containing a comment. See if it starts out ;!zprint
(with any number of ';' allowed), and if it does, attempt to parse
it as an options-map. Return [options error-str] with only options
populated if it works, and throw an exception if it doesn't work.
Use sci/eval-string to create sandboxed functions if any exist in
the options map."
[zprint-num s]
(let [s-onesemi (clojure.string/replace s #"^;+" ";")