blob: 7ba16878a1e83ff8bad2fcee45382e05dff12333 (
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
|
(.module:
[lux (#- Module)
[control
["." monad (#+ Monad do)]
["ex" exception (#+ exception:)]
pipe]
[data
["." bit ("#/." equivalence)]
["." maybe]
["." error]
["." product]
[format
["." binary (#+ Format)]]
["." text
[format (#- Format)]]
[collection
["." list ("#/." functor fold)]
["dict" dictionary (#+ Dictionary)]
["." set (#+ Set)]]]
[world
[file (#+ File System)]]]
[//
[io (#+ Context Module)
["io/." context]
["io/." archive]]
["." archive (#+ Signature Key Descriptor Document Archive)]
["/." //]]
["." /dependency (#+ Dependency Graph)])
(exception: #export (cannot-delete-file {file File})
(ex.report ["File" file]))
(exception: #export (stale-document {module ///.Module} {current-hash Nat} {stale-hash Nat})
(ex.report ["Module" module]
["Current hash" (%n current-hash)]
["Stale hash" (%n stale-hash)]))
(exception: #export (mismatched-signature {module ///.Module} {expected Signature} {actual Signature})
(ex.report ["Module" module]
["Expected" (archive.describe expected)]
["Actual" (archive.describe actual)]))
(do-template [<name>]
[(exception: #export (<name> {message Text})
message)]
[cannot-load-definition]
)
## General
(def: #export (cached System<m> root)
(All [m] (-> (System m) File (m (List File))))
(|> root
(io/archive.archive System<m>)
(do> (:: System<m> &monad)
[(:: System<m> files)]
[(monad.map @ (function (recur file)
(do @
[is-dir? (:: System<m> directory? file)]
(if is-dir?
(|> file
(do> @
[(:: System<m> files)]
[(monad.map @ recur)]
[list.concat
(list& (maybe.assume (io/archive.module System<m> root file)))
wrap]))
(wrap (list))))))]
[list.concat wrap])))
## Clean
(def: (delete System<m> document)
(All [m] (-> (System m) File (m Any)))
(do (:: System<m> &monad)
[deleted? (:: System<m> delete document)]
(if deleted?
(wrap [])
(:: System<m> throw cannot-delete-file document))))
(def: (un-install System<m> root module)
(All [m] (-> (System m) File Module (m Any)))
(let [document (io/archive.document System<m> root module)]
(|> document
(do> (:: System<m> &monad)
[(:: System<m> files)]
[(monad.map @ (function (_ file)
(do @
[? (:: System<m> directory? file)]
(if ?
(wrap #0)
(do @
[_ (..delete System<m> file)]
(wrap #1))))))]
[(list.every? (bit/= #1))
(if> [(..delete System<m> document)]
[(wrap [])])]))))
(def: #export (clean System<m> root wanted-modules)
(All [m] (-> (System m) File (Set Module) (m Any)))
(|> root
(do> (:: System<m> &monad)
[(..cached System<m>)]
[(list.filter (bit.complement (set.member? wanted-modules)))
(monad.map @ (un-install System<m> root))])))
## Load
(def: signature
(Format Signature)
($_ binary.and binary.name binary.text))
(def: descriptor
(Format Descriptor)
($_ binary.and binary.nat binary.text (binary.list binary.text) (binary.ignore #.Cached)))
(def: document
(All [a] (-> (Format a) (Format [Signature Descriptor a])))
(|>> ($_ binary.and ..signature ..descriptor)))
(def: (load-document System<m> contexts root key binary module)
(All [m d] (-> (System m) (List File) File (Key d) (Format d) Module
(m (Maybe [Dependency (Document d)]))))
(do (:: System<m> &monad)
[document' (:: System<m> read (io/archive.document System<m> root module))
[module' source-code] (io/context.read System<m> contexts module)
#let [current-hash (:: text.hash hash source-code)]]
(case (do error.monad
[[signature descriptor content] (binary.read (..document binary) document')
#let [[document-hash _file references _state] descriptor]
_ (ex.assert mismatched-signature [module (get@ #archive.signature key) signature]
(:: archive.equivalence =
(get@ #archive.signature key)
signature))
_ (ex.assert stale-document [module current-hash document-hash]
(n/= current-hash document-hash))
document (archive.write key signature descriptor content)]
(wrap [[module references] document]))
(#error.Success [dependency document])
(wrap (#.Some [dependency document]))
(#error.Failure error)
(do @
[_ (un-install System<m> root module)]
(wrap #.None)))))
(def: #export (load-archive System<m> contexts root key binary)
(All [m d] (-> (System m) (List Context) File (Key d) (Format d) (m Archive)))
(do (:: System<m> &monad)
[candidate (|> root
(do> @
[(..cached System<m>)]
[(monad.map @ (load-document System<m> contexts root key binary))
(:: @ map (list/fold (function (_ full-document archive)
(case full-document
(#.Some [[module references] document])
(dict.put module [references document] archive)
#.None
archive))
(: (Dictionary Text [(List Module) (Ex [d] (Document d))])
(dict.new text.hash))))]))
#let [candidate-entries (dict.entries candidate)
candidate-dependencies (list/map (product.both id product.left)
candidate-entries)
candidate-archive (|> candidate-entries
(list/map (product.both id product.right))
(dict.from-list text.hash))
graph (|> candidate
dict.entries
(list/map (product.both id product.left))
/dependency.graph
(/dependency.prune candidate-archive))
archive (list/fold (function (_ module archive)
(if (dict.contains? module graph)
archive
(dict.remove module archive)))
candidate-archive
(dict.keys candidate))]]
(wrap archive)))
|
