blob: 49358065bcbc90876fcd0bbd32dff9e29e238342 (
plain)
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
|
(.module:
[lux (#- Module)
[abstract
["." equivalence (#+ Equivalence)]
["." monad (#+ do)]]
[control
["." try (#+ Try)]
["." exception (#+ exception:)]
["." function]
["<>" parser
["<b>" binary (#+ Parser)]]]
[data
[binary (#+ Binary)]
["." product]
["." name]
["." text ("#@." equivalence)
["%" format (#+ format)]]
[format
["." binary (#+ Writer)]]
[number
["n" nat]]
[collection
["." list ("#@." functor fold)]
["." dictionary (#+ Dictionary)]
["." set]]]
[type
abstract]
[world
[file (#+ File)]]]
[/
["." signature (#+ Signature)]
["." key (#+ Key)]
["." descriptor (#+ Module Descriptor)]
["." document (#+ Document)]
[///
[version (#+ Version)]]])
(exception: #export (unknown-document {module Module}
{known-modules (List Module)})
(exception.report
["Module" module]
["Known Modules" (exception.enumerate function.identity known-modules)]))
(exception: #export (cannot-replace-document {module Module}
{old (Document Any)}
{new (Document Any)})
(exception.report
["Module" module]
["Old key" (signature.description (document.signature old))]
["New key" (signature.description (document.signature new))]))
(exception: #export (module-has-already-been-reserved {module Module})
(exception.report
["Module" module]))
(exception: #export (module-must-be-reserved-before-it-can-be-added {module Module})
(exception.report
["Module" module]))
(exception: #export (module-is-only-reserved {module Module})
(exception.report
["Module" module]))
(type: #export ID Nat)
(abstract: #export Archive
{}
(Dictionary Module [ID (Maybe [Descriptor (Document Any)])])
(def: #export empty
Archive
(:abstraction (dictionary.new text.hash)))
(def: next
(-> Archive ID)
(|>> :representation dictionary.size))
(def: #export (id module archive)
(-> Module Archive (Try ID))
(case (dictionary.get module (:representation archive))
(#.Some [id _])
(#try.Success id)
#.None
(exception.throw ..unknown-document [module
(dictionary.keys (:representation archive))])))
(def: #export (reserve module archive)
(-> Module Archive (Try [ID Archive]))
(case (dictionary.get module (:representation archive))
(#.Some _)
(exception.throw ..module-has-already-been-reserved [module])
#.None
(let [id (..next archive)]
(#try.Success [id
(|> archive
:representation
(dictionary.put module [id #.None])
:abstraction)]))))
(def: #export (add module [descriptor document] archive)
(-> Module [Descriptor (Document Any)] Archive (Try Archive))
(case (dictionary.get module (:representation archive))
(#.Some [id #.None])
(#try.Success (|> archive
:representation
(dictionary.put module [id (#.Some [descriptor document])])
:abstraction))
(#.Some [id (#.Some [existing-descriptor existing-document])])
(if (is? document existing-document)
## TODO: Find out why this code allows for the same module to be added more than once. It looks fishy...
(#try.Success archive)
(exception.throw ..cannot-replace-document [module existing-document document]))
#.None
(exception.throw ..module-must-be-reserved-before-it-can-be-added [module])))
(def: #export (find module archive)
(-> Module Archive (Try [Descriptor (Document Any)]))
(case (dictionary.get module (:representation archive))
(#.Some [id (#.Some document)])
(#try.Success document)
(#.Some [id #.None])
(exception.throw ..module-is-only-reserved [module])
#.None
(exception.throw ..unknown-document [module
(dictionary.keys (:representation archive))])))
(def: #export (archived? archive module)
(-> Archive Module Bit)
(case (find module archive)
(#try.Success _)
yes
(#try.Failure _)
no))
(def: #export archived
(-> Archive (List Module))
(|>> :representation
dictionary.entries
(list.search-all (function (_ [module [id descriptor+document]])
(case descriptor+document
(#.Some _) (#.Some module)
#.None #.None)))))
(def: #export reserved
(-> Archive (List Module))
(|>> :representation
dictionary.keys))
(def: #export reservations
(-> Archive (List [Module ID]))
(|>> :representation
dictionary.entries
(list@map (function (_ [module [id _]])
[module id]))))
(def: #export (merge additions archive)
(-> Archive Archive (Try Archive))
(monad.fold try.monad
(function (_ [module' [id descriptor+document']] archive')
(case descriptor+document'
(#.Some descriptor+document')
(if (archived? archive' module')
(#try.Success archive')
(..add module' descriptor+document' archive'))
#.None
(#try.Success archive')))
archive
(dictionary.entries (:representation additions))))
(type: Reservation [Module ID])
(type: Frozen [Version (List Reservation)])
(def: reader
(Parser ..Frozen)
(<>.and <b>.text
(<b>.list (<>.and <b>.text <b>.nat))))
(def: writer
(Writer ..Frozen)
(binary.and binary.text
(binary.list (binary.and binary.text binary.nat))))
(def: #export (export version archive)
(-> Version Archive Binary)
(|> archive
:representation
dictionary.entries
(list.search-all (function (_ [module [id descriptor+document]])
(case descriptor+document
(#.Some _) (#.Some [module id])
#.None #.None)))
[version]
(binary.run ..writer)))
(exception: #export (version-mismatch {expected Version} {actual Version})
(exception.report
["Expected" (%.text expected)]
["Actual" (%.text actual)]))
(exception: #export corrupt-data)
(def: (correct-modules? reservations)
(-> (List Reservation) Bit)
(n.= (list.size reservations)
(|> reservations
(list@map product.left)
(set.from-list text.hash)
set.size)))
(def: (correct-ids? reservations)
(-> (List Reservation) Bit)
(n.= (list.size reservations)
(|> reservations
(list@map product.right)
(set.from-list n.hash)
set.size)))
(def: (correct-reservations? reservations)
(-> (List Reservation) Bit)
(and (correct-modules? reservations)
(correct-ids? reservations)))
(def: #export (import expected binary)
(-> Version Binary (Try Archive))
(do try.monad
[[actual reservations] (<b>.run ..reader binary)
_ (exception.assert ..version-mismatch [expected actual]
(text@= expected actual))
_ (exception.assert ..corrupt-data []
(correct-reservations? reservations))]
(wrap (|> reservations
(list@fold (function (_ [module id] archive)
(dictionary.put module [id #.None] archive))
(:representation ..empty))
:abstraction))))
)
|
