/
wrap.clj
86 lines (63 loc) · 2.81 KB
/
wrap.clj
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
(ns ^:no-doc structural-typing.guts.preds.wrap
(:use structural-typing.clojure.core)
(:require [such.readable :as readable]
[such.metadata :as meta]
[structural-typing.assist.oopsie :as oopsie]
[structural-typing.assist.defaults :as defaults]
[structural-typing.guts.expred :as expred])
(:refer-clojure :exclude [any?]))
;; TODO: make readable have the "ensure-meta" behavior
;; TODO: This should really be two files: one for lifting behavior and one for annotating-via-metadata
(defn ensure-meta [f k v] (if (contains? (meta f) k) f (meta/assoc f k v)))
(defn get-predicate-string [f] (readable/fn-string f))
(defn get-predicate [f] (meta/get f ::original-predicate f))
(defn get-explainer [f] (meta/get f ::predicate-explainer defaults/default-predicate-explainer))
(defn stash-defaults [f]
(-> f
(ensure-meta ::original-predicate f)
(readable/rename (readable/fn-string f))))
(defn replace-predicate-string [f name] (readable/rename f name))
(defn replace-explainer [f explainer] (meta/assoc f ::predicate-explainer explainer))
(def ^:private lifted-mark ::lifted)
(defn mark-as-lifted
"A pred so marked is not lifted again. You can call [[lift-pred]] safely many times."
[pred]
(vary-meta pred assoc lifted-mark true))
(defn already-lifted? [pred]
(lifted-mark (meta pred)))
(defn ->expred [pred]
(expred/->ExPred (get-predicate pred)
(get-predicate-string pred)
(get-explainer pred)))
;; In keeping with the structural theme of the library, an object is an Oopsie if it
;; contains an `:explainer`.
(defn oopsie? [x] (and (map? x)
(contains? x :explainer)))
(defn- mkfn:optional [pred]
(fn [value]
(if (nil? value)
true
(pred value))))
(defn give-lifted-predicate-a-nice-string [pred expred]
(replace-predicate-string pred (:predicate-string expred)))
(defn protect-pred [pred protection-subtractions]
(when-not (empty? (remove #{:allow-exceptions :check-nil} protection-subtractions))
(throw (new Exception (str protection-subtractions))))
(-> pred
(cond-> (not (any? #{:allow-exceptions} protection-subtractions)) pred:exception->false
(not (any? #{:check-nil} protection-subtractions)) mkfn:optional)))
(defn lift-expred [expred protection-subtractions]
(let [pred-with-protections (protect-pred (:predicate expred) protection-subtractions)]
(-> (fn [exval]
(if (pred-with-protections (:leaf-value exval))
[]
(vector (merge expred exval))))
mark-as-lifted
(give-lifted-predicate-a-nice-string expred))))
(defn lift
([pred protection-subtractions]
(if (already-lifted? pred)
pred
(lift-expred (->expred pred) protection-subtractions)))
([pred]
(lift pred [])))