-
Notifications
You must be signed in to change notification settings - Fork 3
/
highlight.cljc
153 lines (134 loc) · 4.58 KB
/
highlight.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
(ns exoscale.lingo.highlight
(:require [clojure.pprint :as pp]
[clojure.string :as str]
[exoscale.lingo.utils :as u]))
(defn- subpath?
"True'ish if `x` is a subpath of `y`. Could use subvec but will do for now"
[x y]
(= (take (count x) y) x))
(defn focus
"Takes a value, runs `mismatch-fn` on all values that are not in `paths` and
runs `match-fn` on all values that are in `paths`. This is usefull to create
values with every irrelevant values blanked and highlights on the relevant
ones for instance"
([m path]
(focus m
path
{}))
([m path opts]
(focus m
path
opts
[]))
([m path {:keys [mismatch-fn match-fn descend-mismatching-nodes?]
:or {mismatch-fn (constantly '_)
match-fn identity}
:as opts}
current-path]
(cond
(= path current-path)
(match-fn m)
(and (not descend-mismatching-nodes?)
(not (subpath? current-path path)))
(mismatch-fn m)
(map? m)
(into {}
(map (fn [[k v]]
[k
(focus v path opts (conj current-path k))]))
m)
(coll? m)
(into (empty m)
(map-indexed (fn [idx x]
(focus x path opts (conj current-path idx))))
m)
:else (mismatch-fn m))))
(defn- marker
[offset len]
(->> (concat (repeat offset " ")
(repeat len "^"))
(apply str)))
(defn- pp-str
[x]
(let [s (with-out-str (pp/pprint x))]
(subs s 0 (dec (count s)))))
(defn- width
[s]
(reduce (fn [x l]
(let [len (count l)]
(if (> len x)
len
x)))
0
(str/split-lines s)))
(defn- pad [i]
(reduce u/string-builder
(u/string-builder)
(repeat i \space)))
(defn- justify-error [s idx]
(let [pad' (pad idx)]
(transduce (comp (map-indexed (fn [i s]
(cond->> s
(not (zero? i))
(str pad'))))
(interpose \newline))
u/string-builder
(str/split-lines s))))
(defn prefix-lines [s prefix]
(transduce (comp (map (fn [s] (str prefix s)))
(interpose \newline))
u/string-builder
(str/split-lines s)))
(def ^:private relevant-mark 'exoscale.lingo/relevant)
(defn- relevant-mark-index
[line]
(str/index-of line (str relevant-mark)))
(defn- replace-mark
[line val idx]
(str/replace line
(str relevant-mark)
(justify-error val idx)))
(defn- prep-val
"Replaces error value with placeholder, then pprint without newline char at the end"
[m in {:as _opts :keys [focus?]}]
(pp-str (focus m in (cond-> {:match-fn (constantly relevant-mark)}
(not focus?)
(assoc :mismatch-fn identity)))))
(defn colorize
[s color]
(cond-> s
(keyword? color)
(u/color color)))
(defn highlight
[value
{:as _pb
:keys [in val pred]
:exoscale.lingo.explain/keys [message]
:or {message (str "Does not conform to " pred)}}
{:as opts :keys [colors? highlight-inline-message?]}]
(let [error-color (when colors? :red)]
(->> (prep-val value in opts)
str/split-lines
(transduce (comp
(map (fn [line]
;; if line contains relevant value, add placholder
;; with rendered error
(if-let [idx (relevant-mark-index line)]
(let [s (pp-str val)]
(str (replace-mark line
(cond-> s
colors?
(u/color :red))
idx)
\newline
(cond-> (-> (str (marker idx (width s)))
(colorize error-color))
highlight-inline-message?
(str \newline
(pad idx)
(colorize message error-color))
colors?
(u/color :red))))
line)))
(interpose \newline))
u/string-builder))))