aboutsummaryrefslogtreecommitdiff
path: root/stdlib
diff options
context:
space:
mode:
Diffstat (limited to '')
-rw-r--r--stdlib/source/lux/control/exception.lux6
-rw-r--r--stdlib/source/lux/data/format/binary.lux119
-rw-r--r--stdlib/source/lux/lang/compiler/meta/archive.lux49
-rw-r--r--stdlib/source/lux/lang/compiler/meta/cache.lux163
-rw-r--r--stdlib/source/lux/lang/compiler/meta/cache/dependency.lux51
-rw-r--r--stdlib/source/lux/lang/compiler/meta/io.lux2
-rw-r--r--stdlib/source/lux/lang/compiler/meta/io/context.lux10
-rw-r--r--stdlib/source/lux/world/file.lux5
8 files changed, 355 insertions, 50 deletions
diff --git a/stdlib/source/lux/control/exception.lux b/stdlib/source/lux/control/exception.lux
index 2ca06defa..80ddeed35 100644
--- a/stdlib/source/lux/control/exception.lux
+++ b/stdlib/source/lux/control/exception.lux
@@ -71,6 +71,12 @@
(All [e] (-> (Exception e) e Error))
(#/.Error (construct exception message)))
+(def: #export (assert exception message test)
+ (All [e] (-> (Exception e) e Bool (Error Any)))
+ (if test
+ (#/.Success [])
+ (..throw exception message)))
+
(syntax: #export (exception: {export csr.export}
{t-vars (p.default (list) csr.type-variables)}
{[name inputs] (p.either (p.seq s.local-symbol (wrap (list)))
diff --git a/stdlib/source/lux/data/format/binary.lux b/stdlib/source/lux/data/format/binary.lux
index cabdf7091..040ae5e8b 100644
--- a/stdlib/source/lux/data/format/binary.lux
+++ b/stdlib/source/lux/data/format/binary.lux
@@ -1,5 +1,5 @@
(.module:
- [lux #- nat int rev]
+ [lux #- nat int rev list]
(lux (control [monad #+ do Monad]
["p" parser]
["ex" exception #+ exception:])
@@ -14,8 +14,9 @@
(ex.report ["Blob length" (%n length)]
["Read bytes" (%n read)]))
-(exception: #export (invalid-bool {byte Nat})
- (%n byte))
+(exception: #export (invalid-tag {range Nat} {byte Nat})
+ (ex.report ["Range" (%n range)]
+ ["Byte" (%n byte)]))
## Types
(type: #export Offset Nat)
@@ -33,13 +34,13 @@
(type: #export (Write a)
(-> a [Size (-> Offset Blob Blob)]))
-(type: #export (Format a)
+(type: #export (Binary a)
{#read (Read a)
#write (Write a)})
## Operators
(def: #export (read format input)
- (All [a] (-> (Format a) Blob (error.Error a)))
+ (All [a] (-> (Binary a) Blob (error.Error a)))
(case ((get@ #read format) [+0 input])
(#error.Error msg)
(#error.Error msg)
@@ -51,26 +52,14 @@
(ex.throw blob-was-not-fully-read [length end])))))
(def: #export (write format value)
- (All [a] (-> (Format a) a Blob))
+ (All [a] (-> (Binary a) a Blob))
(let [[valueS valueT] ((get@ #write format) value)]
(|> valueS blob.create (valueT +0))))
-## Combinators
-(def: #export (seq preF postF)
- (All [a b] (-> (Format a) (Format b) (Format [a b])))
- {#read (p.seq (get@ #read preF) (get@ #read postF))
- #write (function (_ [preV postV])
- (let [[preS preT] ((get@ #write preF) preV)
- [postS postT] ((get@ #write postF) postV)]
- [(n/+ preS postS)
- (function (_ offset)
- (|>> (preT offset)
- (postT (n/+ preS offset))))]))})
-
## Primitives
(do-template [<name> <size> <read> <write>]
[(def: <name>
- (Format (I64 Any))
+ (Binary (I64 Any))
{#read (function (_ [offset blob])
(case (<read> offset blob)
(#error.Success data)
@@ -81,7 +70,9 @@
#write (function (_ value)
[<size>
(function (_ offset blob)
- (error.assume (<write> offset value blob)))])})]
+ (|> blob
+ (<write> offset value)
+ error.assume))])})]
[bits/8 size/8 blob.read/8 blob.write/8]
[bits/16 size/16 blob.read/16 blob.write/16]
@@ -89,9 +80,68 @@
[bits/64 size/64 blob.read/64 blob.write/64]
)
+## Combinators
+(def: #export (alt leftB rightB)
+ (All [l r] (-> (Binary l) (Binary r) (Binary (| l r))))
+ {#read (do p.Monad<Parser>
+ [flag (get@ #read bits/8)]
+ (case flag
+ +0 (:: @ map (|>> #.Left) (get@ #read leftB))
+ +1 (:: @ map (|>> #.Right) (get@ #read rightB))
+ _ (p.lift (ex.throw invalid-tag [+2 (.nat flag)]))))
+ #write (function (_ altV)
+ (case altV
+ (#.Left leftV)
+ (let [[leftS leftT] ((get@ #write leftB) leftV)]
+ [(.inc leftS)
+ (function (_ offset blob)
+ (|> blob
+ (blob.write/8 offset +0)
+ error.assume
+ (leftT (.inc offset))))])
+
+ (#.Right rightV)
+ (let [[rightS rightT] ((get@ #write rightB) rightV)]
+ [(.inc rightS)
+ (function (_ offset blob)
+ (|> blob
+ (blob.write/8 offset +1)
+ error.assume
+ (rightT (.inc offset))))])
+ ))})
+
+(def: #export (seq preB postB)
+ (All [a b] (-> (Binary a) (Binary b) (Binary [a b])))
+ {#read (p.seq (get@ #read preB) (get@ #read postB))
+ #write (function (_ [preV postV])
+ (let [[preS preT] ((get@ #write preB) preV)
+ [postS postT] ((get@ #write postB) postV)]
+ [(n/+ preS postS)
+ (function (_ offset)
+ (|>> (preT offset)
+ (postT (n/+ preS offset))))]))})
+
+(def: #export (rec body)
+ (All [a] (-> (-> (Binary a) (Binary a)) (Binary a)))
+ {#read (function (_ input)
+ (let [read (get@ #read (body (rec body)))]
+ (read input)))
+ #write (function (_ value)
+ (let [write (get@ #write (body (rec body)))]
+ (write value)))})
+
## Utilities
+(def: #export unit
+ (Binary Any)
+ {#read (function (_ input)
+ (#error.Success [input []]))
+ #write (function (_ value)
+ [+0
+ (function (_ offset blob)
+ blob)])})
+
(def: #export bool
- (Format Bool)
+ (Binary Bool)
{#read (function (_ [offset blob])
(case (blob.read/8 offset blob)
(#error.Success data)
@@ -102,29 +152,29 @@
[+1 true])
_
- (ex.throw invalid-bool data))
+ (ex.throw invalid-tag [+2 data]))
(#error.Error error)
(#error.Error error)))
#write (function (_ value)
[+1
(function (_ offset blob)
- (exec (error.assume (blob.write/8 offset (if value +1 +0) blob))
- blob))])}
- )
+ (|> blob
+ (blob.write/8 offset (if value +1 +0))
+ error.assume))])})
-(def: #export nat (Format Nat) (:assume ..bits/64))
-(def: #export int (Format Int) (:assume ..bits/64))
-(def: #export rev (Format Rev) (:assume ..bits/64))
+(def: #export nat (Binary Nat) (:assume ..bits/64))
+(def: #export int (Binary Int) (:assume ..bits/64))
+(def: #export rev (Binary Rev) (:assume ..bits/64))
(def: #export frac
- (Format Frac)
+ (Binary Frac)
(let [(^slots [#read #write]) ..bits/64]
{#read (:: p.Monad<Parser> map number.bits-to-frac read)
#write (|>> number.frac-to-bits write)}))
(def: #export blob
- (Format Blob)
+ (Binary Blob)
{#read (do p.Monad<Parser>
[size (get@ #read nat)]
(function (_ [offset blob])
@@ -142,9 +192,16 @@
(blob.copy size +0 value (n/+ size/64 offset) blob))))]))})
(def: #export text
- (Format Text)
+ (Binary Text)
(let [(^slots [#read #write]) ..blob]
{#read (do p.Monad<Parser>
[utf8 read]
(p.lift (encoding.from-utf8 utf8)))
#write (|>> encoding.to-utf8 write)}))
+
+(def: #export (list value)
+ (All [a] (-> (Binary a) (Binary (List a))))
+ (..rec
+ (function (_ recur)
+ (..alt ..unit
+ (..seq value recur)))))
diff --git a/stdlib/source/lux/lang/compiler/meta/archive.lux b/stdlib/source/lux/lang/compiler/meta/archive.lux
index f61476111..371164ee4 100644
--- a/stdlib/source/lux/lang/compiler/meta/archive.lux
+++ b/stdlib/source/lux/lang/compiler/meta/archive.lux
@@ -13,41 +13,54 @@
[////])
## Key
+(type: #export Signature
+ {#name Ident
+ #version Text})
+
+(def: Equivalence<Signature>
+ (Equivalence Signature)
+ (equivalence.product ident.Equivalence<Ident> text.Equivalence<Text>))
+
+(def: (describe signature)
+ (-> Signature Text)
+ (format (%ident (get@ #name signature)) " " (get@ #version signature)))
+
(abstract: #export (Key k)
{}
- {#name Ident
- #version Text}
+ Signature
- (def: Equivalence<Key>'
- (equivalence.product ident.Equivalence<Ident> text.Equivalence<Text>))
-
(struct: #export Equivalence<Key>
(All [k] (Equivalence (Key k)))
(def: (= reference sample)
- (:: Equivalence<Key>' = (:representation reference) (:representation sample))))
+ (:: Equivalence<Signature> = (:representation reference) (:representation sample))))
(def: #export default
(Key Nothing)
(:abstraction {#name ["" ""]
#version ////.version}))
- (def: (describe (^:representation key))
- (-> (Key Any) Text)
- (format (%ident (get@ #name key)) " " (get@ #version key)))
+ (def: #export signature
+ (-> (Key Any) Signature)
+ (|>> :representation))
)
## Document
(exception: #export (invalid-key-for-document {expected (Key Any)} {actual (Key Any)})
- (ex.report ["Expected" (describe expected)]
- ["Actual" (describe actual)]))
+ (ex.report ["Expected" (describe (..signature expected))]
+ ["Actual" (describe (..signature actual))]))
+
+(exception: #export (signature-does-not-match-key {key (Key Any)} {signature Signature})
+ (ex.report ["Key" (describe (..signature key))]
+ ["Signature" (describe signature)]))
(type: #export (Document d)
{#key (Key d)
+ #hash Nat
#value d})
(def: #export (open expected [actual value])
- (All [e] (-> (Key e) (Document Any) (Error e)))
+ (All [d] (-> (Key d) (Document Any) (Error d)))
(if (:: Equivalence<Key> = expected actual)
(#error.Success (:share [e]
{(Key e)
@@ -56,11 +69,19 @@
value}))
(ex.throw invalid-key-for-document [expected actual])))
+(def: #export (close key signature hash value)
+ (All [d] (-> (Key d) Signature Nat d (Error (Document d))))
+ (if (:: Equivalence<Signature> = (..signature key) signature)
+ (#error.Success {#key key
+ #hash hash
+ #value value})
+ (ex.throw signature-does-not-match-key [key signature])))
+
## Archive
(exception: #export (cannot-replace-document-in-archive {name Text} {old (Document Any)} {new (Document Any)})
(ex.report ["Module's name" name]
- ["Old document's key" (describe (get@ #key old))]
- ["New document's key" (describe (get@ #key new))]))
+ ["Old document's key" (describe (..signature (get@ #key old)))]
+ ["New document's key" (describe (..signature (get@ #key new)))]))
(type: #export Archive
(Dict Text (Ex [d] (Document d))))
diff --git a/stdlib/source/lux/lang/compiler/meta/cache.lux b/stdlib/source/lux/lang/compiler/meta/cache.lux
new file mode 100644
index 000000000..153679ef0
--- /dev/null
+++ b/stdlib/source/lux/lang/compiler/meta/cache.lux
@@ -0,0 +1,163 @@
+(.module:
+ [lux #- Module]
+ (lux (control [monad #+ Monad do]
+ ["ex" exception #+ exception:]
+ pipe)
+ (data [bool "bool/" Equivalence<Bool>]
+ [maybe]
+ [error]
+ [product]
+ (format [binary #+ Binary])
+ [text]
+ text/format
+ (coll [list "list/" Functor<List> Fold<List>]
+ (dictionary ["dict" unordered #+ Dict])
+ (set ["set" unordered #+ Set])))
+ (world [file #+ File System]))
+ [//io #+ Context Module]
+ [//io/context]
+ [//io/archive]
+ [//archive #+ Signature Key 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)
+ (let [name (binary.seq binary.text binary.text)
+ version binary.text]
+ (binary.seq name version)))
+
+(def: imports
+ (Binary (List Module))
+ (binary.list binary.text))
+
+(def: document
+ (All [a] (-> (Binary a) (Binary [Signature Nat (List Module) a])))
+ (|>> ($_ binary.seq ..signature binary.nat ..imports)))
+
+(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 document-hash imports content] (binary.read (..document binary) document')
+ _ (ex.assert stale-document [module current-hash document-hash]
+ (n/= current-hash document-hash))
+ document (//archive.close key signature document-hash content)]
+ (wrap [[module imports] 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 imports] document])
+ (dict.put module [imports document] archive)
+
+ #.None
+ archive))
+ (: (Dict 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)))
diff --git a/stdlib/source/lux/lang/compiler/meta/cache/dependency.lux b/stdlib/source/lux/lang/compiler/meta/cache/dependency.lux
new file mode 100644
index 000000000..28fcfccc8
--- /dev/null
+++ b/stdlib/source/lux/lang/compiler/meta/cache/dependency.lux
@@ -0,0 +1,51 @@
+(.module:
+ [lux #- Module]
+ (lux (data [text]
+ (coll [list "list/" Functor<List> Fold<List>]
+ (dictionary ["dict" unordered #+ Dict]))))
+ [///io #+ Module]
+ [///archive #+ Archive])
+
+(type: #export Graph (Dict Module (List Module)))
+
+(def: #export empty Graph (dict.new text.Hash<Text>))
+
+(def: #export (add to from)
+ (-> Module Module Graph Graph)
+ (|>> (dict.update~ from (list) (|>> (#.Cons to)))
+ (dict.update~ to (list) id)))
+
+(def: dependents
+ (-> Module Graph (Maybe (List Text)))
+ dict.get)
+
+(def: #export (remove module dependency)
+ (-> Module Graph Graph)
+ (case (dependents module dependency)
+ (#.Some dependents)
+ (list/fold remove (dict.remove module dependency) dependents)
+
+ #.None
+ dependency))
+
+(type: #export Dependency
+ {#module Module
+ #imports (List Module)})
+
+(def: #export (dependency [module imports])
+ (-> Dependency Graph)
+ (list/fold (..add module) ..empty imports))
+
+(def: #export graph
+ (-> (List Dependency) Graph)
+ (|>> (list/map ..dependency)
+ (list/fold dict.merge empty)))
+
+(def: #export (prune archive graph)
+ (-> Archive Graph Graph)
+ (list/fold (function (_ module graph)
+ (if (dict.contains? module archive)
+ graph
+ (..remove module graph)))
+ graph
+ (dict.keys graph)))
diff --git a/stdlib/source/lux/lang/compiler/meta/io.lux b/stdlib/source/lux/lang/compiler/meta/io.lux
index 6be4605f2..e440c16f9 100644
--- a/stdlib/source/lux/lang/compiler/meta/io.lux
+++ b/stdlib/source/lux/lang/compiler/meta/io.lux
@@ -9,6 +9,8 @@
(world [file #+ File System]
[blob #+ Blob])))
+(type: #export Context File)
+
(type: #export Module Text)
(def: #export (sanitize system)
diff --git a/stdlib/source/lux/lang/compiler/meta/io/context.lux b/stdlib/source/lux/lang/compiler/meta/io/context.lux
index d03dcbdd8..327f52cf5 100644
--- a/stdlib/source/lux/lang/compiler/meta/io/context.lux
+++ b/stdlib/source/lux/lang/compiler/meta/io/context.lux
@@ -1,5 +1,5 @@
(.module:
- [lux #- Module]
+ [lux #- Module Code]
(lux (control monad
["ex" exception #+ Exception exception:])
(data [error]
@@ -8,9 +8,7 @@
(world [file #+ File System]
[blob #+ Blob]))
[/////host]
- [// #+ Module])
-
-(type: #export Context File)
+ [// #+ Context Module])
(type: #export Extension Text)
@@ -72,8 +70,10 @@
#.None
(try System<m> computations' exception message)))))
+(type: #export Code Text)
+
(def: #export (read System<m> contexts name)
- (All [m] (-> (System m) (List Context) Module (m [Module Text])))
+ (All [m] (-> (System m) (List Context) Module (m [Text Code])))
(let [find-source' (find-source System<m> contexts name)]
(do (:: System<m> &monad)
[[path file] (try System<m>
diff --git a/stdlib/source/lux/world/file.lux b/stdlib/source/lux/world/file.lux
index 21f5c1d3c..24c38024c 100644
--- a/stdlib/source/lux/world/file.lux
+++ b/stdlib/source/lux/world/file.lux
@@ -29,6 +29,9 @@
(: (All [a] (-> (m a) (m (Error a))))
try)
+
+ (: (All [a] (-> (Error a) (m a)))
+ lift)
(do-template [<name>]
[(: (-> Blob File (m Any))
@@ -136,6 +139,8 @@
(do io.Monad<IO>
[outcome computation]
(:: io.Monad<Process> wrap outcome)))
+
+ (def: lift (:: io.Monad<IO> wrap))
(do-template [<name> <flag>]
[(def: (<name> data file)
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-05 11:36:30 +0000