aboutsummaryrefslogtreecommitdiff
path: root/stdlib/source/lux/tool/compiler/meta/archive.lux
diff options
context:
space:
mode:
Diffstat (limited to '')
-rw-r--r--stdlib/source/lux/tool/compiler/meta/archive.lux279
1 files changed, 0 insertions, 279 deletions
diff --git a/stdlib/source/lux/tool/compiler/meta/archive.lux b/stdlib/source/lux/tool/compiler/meta/archive.lux
deleted file mode 100644
index 09b501ef3..000000000
--- a/stdlib/source/lux/tool/compiler/meta/archive.lux
+++ /dev/null
@@ -1,279 +0,0 @@
-(.module:
- [lux (#- Module)
- [abstract
- ["." equivalence (#+ Equivalence)]
- ["." monad (#+ do)]]
- [control
- ["." try (#+ Try)]
- ["." exception (#+ exception:)]
- ["." function]
- ["<>" parser
- ["<b>" binary (#+ Parser)]]]
- [data
- [binary (#+ Binary)]
- ["." product]
- ["." name]
- ["." text
- ["%" format (#+ format)]]
- [format
- ["." binary (#+ Writer)]]
- [collection
- ["." list ("#\." functor fold)]
- ["." dictionary (#+ Dictionary)]
- ["." set]
- ["." row (#+ Row)]]]
- [math
- [number
- ["n" nat ("#\." equivalence)]]]
- [type
- abstract]]
- [/
- ["." artifact]
- ["." signature (#+ Signature)]
- ["." key (#+ Key)]
- ["." descriptor (#+ Module Descriptor)]
- ["." document (#+ Document)]
- [///
- [version (#+ Version)]]])
-
-(type: #export Output
- (Row [artifact.ID Binary]))
-
-(exception: #export (unknown_document {module Module}
- {known_modules (List Module)})
- (exception.report
- ["Module" (%.text module)]
- ["Known Modules" (exception.enumerate %.text known_modules)]))
-
-(exception: #export (cannot_replace_document {module Module}
- {old (Document Any)}
- {new (Document Any)})
- (exception.report
- ["Module" (%.text 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" (%.text module)]))
-
-(exception: #export (module_must_be_reserved_before_it_can_be_added {module Module})
- (exception.report
- ["Module" (%.text module)]))
-
-(exception: #export (module_is_only_reserved {module Module})
- (exception.report
- ["Module" (%.text module)]))
-
-(type: #export ID
- Nat)
-
-(def: #export runtime_module
- Module
- "")
-
-(abstract: #export Archive
- {#next ID
- #resolver (Dictionary Module [ID (Maybe [Descriptor (Document Any) Output])])}
-
- (def: next
- (-> Archive ID)
- (|>> :representation (get@ #next)))
-
- (def: #export empty
- Archive
- (:abstraction {#next 0
- #resolver (dictionary.new text.hash)}))
-
- (def: #export (id module archive)
- (-> Module Archive (Try ID))
- (let [(^slots [#..resolver]) (:representation archive)]
- (case (dictionary.get module resolver)
- (#.Some [id _])
- (#try.Success id)
-
- #.None
- (exception.throw ..unknown_document [module
- (dictionary.keys resolver)]))))
-
- (def: #export (reserve module archive)
- (-> Module Archive (Try [ID Archive]))
- (let [(^slots [#..next #..resolver]) (:representation archive)]
- (case (dictionary.get module resolver)
- (#.Some _)
- (exception.throw ..module_has_already_been_reserved [module])
-
- #.None
- (#try.Success [next
- (|> archive
- :representation
- (update@ #..resolver (dictionary.put module [next #.None]))
- (update@ #..next inc)
- :abstraction)]))))
-
- (def: #export (add module [descriptor document output] archive)
- (-> Module [Descriptor (Document Any) Output] Archive (Try Archive))
- (let [(^slots [#..resolver]) (:representation archive)]
- (case (dictionary.get module resolver)
- (#.Some [id #.None])
- (#try.Success (|> archive
- :representation
- (update@ #..resolver (dictionary.put module [id (#.Some [descriptor document output])]))
- :abstraction))
-
- (#.Some [id (#.Some [existing_descriptor existing_document existing_output])])
- (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) Output]))
- (let [(^slots [#..resolver]) (:representation archive)]
- (case (dictionary.get module resolver)
- (#.Some [id (#.Some entry)])
- (#try.Success entry)
-
- (#.Some [id #.None])
- (exception.throw ..module_is_only_reserved [module])
-
- #.None
- (exception.throw ..unknown_document [module
- (dictionary.keys resolver)]))))
-
- (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
- (get@ #resolver)
- dictionary.entries
- (list.all (function (_ [module [id descriptor+document]])
- (case descriptor+document
- (#.Some _) (#.Some module)
- #.None #.None)))))
-
- (def: #export (reserved? archive module)
- (-> Archive Module Bit)
- (let [(^slots [#..resolver]) (:representation archive)]
- (case (dictionary.get module resolver)
- (#.Some [id _])
- yes
-
- #.None
- no)))
-
- (def: #export reserved
- (-> Archive (List Module))
- (|>> :representation
- (get@ #resolver)
- dictionary.keys))
-
- (def: #export reservations
- (-> Archive (List [Module ID]))
- (|>> :representation
- (get@ #resolver)
- dictionary.entries
- (list\map (function (_ [module [id _]])
- [module id]))))
-
- (def: #export (merge additions archive)
- (-> Archive Archive Archive)
- (let [[+next +resolver] (:representation additions)]
- (|> archive
- :representation
- (update@ #next (n.max +next))
- (update@ #resolver (function (_ resolver)
- (list\fold (function (_ [module [id entry]] resolver)
- (case entry
- (#.Some _)
- (dictionary.put module [id entry] resolver)
-
- #.None
- resolver))
- resolver
- (dictionary.entries +resolver))))
- :abstraction)))
-
- (type: Reservation [Module ID])
- (type: Frozen [Version ID (List Reservation)])
-
- (def: reader
- (Parser ..Frozen)
- ($_ <>.and
- <b>.nat
- <b>.nat
- (<b>.list (<>.and <b>.text <b>.nat))))
-
- (def: writer
- (Writer ..Frozen)
- ($_ binary.and
- binary.nat
- binary.nat
- (binary.list (binary.and binary.text binary.nat))))
-
- (def: #export (export version archive)
- (-> Version Archive Binary)
- (let [(^slots [#..next #..resolver]) (:representation archive)]
- (|> resolver
- dictionary.entries
- (list.all (function (_ [module [id descriptor+document]])
- (case descriptor+document
- (#.Some _) (#.Some [module id])
- #.None #.None)))
- [version next]
- (binary.run ..writer))))
-
- (exception: #export (version_mismatch {expected Version} {actual Version})
- (exception.report
- ["Expected" (%.nat expected)]
- ["Actual" (%.nat 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 next reservations] (<b>.run ..reader binary)
- _ (exception.assert ..version_mismatch [expected actual]
- (n\= expected actual))
- _ (exception.assert ..corrupt_data []
- (correct_reservations? reservations))]
- (wrap (:abstraction
- {#next next
- #resolver (list\fold (function (_ [module id] archive)
- (dictionary.put module [id #.None] archive))
- (get@ #resolver (:representation ..empty))
- reservations)}))))
- )
generated by cgit v1.2.3 (git 2.25.1) at 2024-07-07 17:52:31 +0000