blob: 753a66e89057c77ca9e34c845a14cf930544ee09 (
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
|
(.module:
[lux (#- Module)
[control
[monad (#+ Monad do)]
["ex" exception (#+ exception:)]
pipe]
[data
[bool ("bool/" Equivalence<Bool>)]
[maybe]
[error]
[product]
[format [binary (#+ Binary)]]
["." text
format]
[collection
[list ("list/" Functor<List> Fold<List>)]
["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-cached-file {file File})
(ex.report ["File" file]))
(exception: #export (stale-document {module Text} {current-hash Nat} {stale-hash Nat})
(ex.report ["Module" module]
["Current hash" (%n current-hash)]
["Stale hash" (%n stale-hash)]))
(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-cached-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 false)
(do @
[_ (..delete System<m> file)]
(wrap true))))))]
[(list.every? (bool/= true))
(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 (bool.complement (set.member? wanted-modules)))
(monad.map @ (un-install System<m> root))])))
## Load
(def: signature
(Binary Signature)
($_ binary.seq binary.ident binary.text))
(def: descriptor
(Binary Descriptor)
($_ binary.seq binary.nat binary.text (binary.list binary.text) (binary.ignore #.Cached)))
(def: document
(All [a] (-> (Binary a) (Binary [Signature Descriptor a])))
(|>> ($_ binary.seq ..signature ..descriptor)))
(def: (load-document System<m> contexts root key binary module)
(All [m d] (-> (System m) (List File) File (Key d) (Binary 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<Text> hash source-code)]]
(case (do error.Monad<Error>
[[signature descriptor content] (binary.read (..document binary) document')
#let [[document-hash _file references _state] descriptor]
_ (ex.assert stale-document [module current-hash document-hash]
(n/= current-hash document-hash))
document (//archive.close key signature descriptor content)]
(wrap [[module references] document]))
(#error.Success [dependency document])
(wrap (#.Some [dependency document]))
(#error.Error 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) (Binary 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<Text>))))]))
#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<Text>))
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)))
|