/
compendium.clj
154 lines (128 loc) · 5.46 KB
/
compendium.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
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
(ns ^{:doc "A compendium is 'a collection of concise but detailed information
about a particular subject'. The Midje compendium contains
the currently relevant facts."}
midje.data.compendium
(:require [midje.config :as config]
[midje.data.fact :as fact]
[midje.util.exceptions :refer [user-error]]
[such.maps :as map]))
;;; Facts are stored in a compendium:
(defprotocol CompendiumProtocol
(add-to [this fact-function])
(remove-from [this fact-function])
(remove-namespace-facts-from [this namespace])
(namespace-facts [this namespace])
(all-facts [this])
(named-fact [this namespace name])
(fact-with-guid [this namespace guid])
(previous-version [this fact-function]))
;; The compendium has three maps, each keyed by a namespace name.
;;
;; One maps that namespace to a list of facts (in the order in which
;; the facts were defined, which is usually the order of facts in the file.
;; This map is sorted alphabetically.
;;
;; Another maps to a by-name map of facts for quick lookup by name.
;;
;; Another maps to a body-guid map to allow quick checks for
;; reloading of identical facts.
(defn friendly-ns-name [symbol-or-namespace]
(when (and (symbol? symbol-or-namespace)
(not (find-ns symbol-or-namespace)))
(throw (user-error (str "You tried to work with `" symbol-or-namespace
"` but that namespace has never been loaded."))))
(ns-name symbol-or-namespace))
(defrecord Compendium [by-namespace by-name by-guid last-fact-checked]
CompendiumProtocol
(add-to [this fact-function]
(let [[namespace name guid]
( (juxt fact/namespace fact/name fact/guid)
fact-function)]
(-> this
(assoc-in [:by-namespace namespace]
(conj (by-namespace namespace []) fact-function))
(#(if name
(assoc-in % [:by-name namespace name] fact-function)
%))
(assoc-in [:by-guid namespace guid] fact-function))))
(remove-from [this fact-function]
(letfn [(vector-remove [vector target]
(let [index-to-exclude (.indexOf ^clojure.lang.PersistentVector vector target)]
(assert (not (neg? index-to-exclude)))
(into (subvec vector 0 index-to-exclude)
(subvec vector (inc index-to-exclude)))))]
(let [[namespace name guid]
( (juxt fact/namespace fact/name fact/guid)
fact-function)
new-namespace-facts
(vector-remove (by-namespace namespace) fact-function)]
(-> this
(assoc-in [:by-namespace namespace] new-namespace-facts)
(map/dissoc-keypath [:by-name namespace name])
(map/dissoc-keypath [:by-guid namespace guid])))))
(remove-namespace-facts-from [this namespace]
(if (and (symbol? namespace)
(not (find-ns namespace)))
this
(let [namespace-name (friendly-ns-name namespace)]
(-> this
(map/dissoc-keypath [:by-namespace namespace-name])
(map/dissoc-keypath [:by-name namespace-name])
(map/dissoc-keypath [:by-guid namespace-name])))))
(namespace-facts [this namespace]
(get by-namespace (friendly-ns-name namespace) []))
(all-facts [this]
(apply concat (vals by-namespace)))
(named-fact [this namespace name]
(get-in by-name [(friendly-ns-name namespace) name]))
(fact-with-guid [this namespace guid]
(get-in by-guid [(friendly-ns-name namespace) guid]))
(previous-version [this fact-function]
(let [[namespace name guid]
( (juxt fact/namespace fact/name fact/guid) fact-function)
existing-named-fact (named-fact this namespace name)
existing-fact-with-guid (fact-with-guid this namespace guid)]
(cond existing-named-fact
existing-named-fact
(and existing-fact-with-guid
(not (fact/name existing-fact-with-guid)))
existing-fact-with-guid
:else
nil))))
(defn fresh []
(Compendium. (sorted-map) {} {}
(fn [] "No fact has been checked.")))
;;; Functions on the mutable compendium.
;;; Functions that change the state are marked with !
;;; Functions that refer to it are marked with <> for no particular reason.
(def global (atom (fresh)))
(defn fresh! []
(reset! global (fresh))
true)
(defmacro with-isolated-compendium [& body]
`(let [current-compendium# @global]
(try
(fresh!)
~@body
(finally
(reset! global current-compendium#)))))
(defn record-fact-check! [function]
(when (fact/allows-itself-to-be-recorded? function)
(swap! global assoc :last-fact-checked function)))
(defn record-fact-existence! [fact-function]
(when (and (fact/allows-itself-to-be-recorded? fact-function)
(config/user-wants-fact-to-be-recorded? fact-function))
(swap! global #(if-let [previous (previous-version % fact-function)]
(remove-from % previous)
%))
(swap! global add-to fact-function))
;; Returning the fact-function is a kludge required by the
;; way tabular facts are parsed.
fact-function)
(defn remove-namespace-facts-from! [namespace]
(swap! global remove-namespace-facts-from namespace))
(defn remove-from! [namespace]
(swap! global remove-from namespace))
(defn all-facts<> [] (all-facts @global))
(defn namespace-facts<> [namespace] (namespace-facts @global namespace))
(defn last-fact-checked<> [] (:last-fact-checked @global))