aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat (limited to '')
-rw-r--r--stdlib/source/lux/control/parser/binary.lux11
-rw-r--r--stdlib/source/lux/control/remember.lux49
-rw-r--r--stdlib/source/lux/data/binary.lux20
-rw-r--r--stdlib/source/lux/data/format/binary.lux7
-rw-r--r--stdlib/source/lux/data/number/i64.lux6
-rw-r--r--stdlib/source/lux/math/random.lux53
-rw-r--r--stdlib/source/lux/tool/compiler/default/platform.lux32
-rw-r--r--stdlib/source/lux/tool/compiler/meta.lux6
-rw-r--r--stdlib/source/lux/tool/compiler/meta/archive.lux88
-rw-r--r--stdlib/source/lux/tool/compiler/meta/io/archive.lux49
-rw-r--r--stdlib/source/program/compositor.lux22
-rw-r--r--stdlib/source/test/lux/abstract/codec.lux45
-rw-r--r--stdlib/source/test/lux/control.lux2
-rw-r--r--stdlib/source/test/lux/control/remember.lux122
14 files changed, 393 insertions, 119 deletions
diff --git a/stdlib/source/lux/control/parser/binary.lux b/stdlib/source/lux/control/parser/binary.lux
index fed4370bf..0ee4112b1 100644
--- a/stdlib/source/lux/control/parser/binary.lux
+++ b/stdlib/source/lux/control/parser/binary.lux
@@ -13,7 +13,7 @@
["." frac]]
[text
["." encoding]
- ["%" format]]
+ ["%" format (#+ format)]]
[collection
["." row (#+ Row)]]]]
["." // ("#@." monad)])
@@ -43,9 +43,9 @@
(type: #export Size Nat)
(def: #export size/8 Size 1)
-(def: #export size/16 Size 2)
-(def: #export size/32 Size 4)
-(def: #export size/64 Size 8)
+(def: #export size/16 Size (n.* 2 size/8))
+(def: #export size/32 Size (n.* 2 size/16))
+(def: #export size/64 Size (n.* 2 size/32))
(template [<name> <size> <read>]
[(def: #export <name>
@@ -84,7 +84,8 @@
(def: #export (or left right)
(All [l r] (-> (Parser l) (Parser r) (Parser (| l r))))
(do //.monad
- [flag ..nat]
+ [flag (: (Parser Nat)
+ ..bits/8)]
(case flag
0 (:: @ map (|>> #.Left) left)
1 (:: @ map (|>> #.Right) right)
diff --git a/stdlib/source/lux/control/remember.lux b/stdlib/source/lux/control/remember.lux
index 1bf5097ab..24bdacb03 100644
--- a/stdlib/source/lux/control/remember.lux
+++ b/stdlib/source/lux/control/remember.lux
@@ -3,45 +3,48 @@
[abstract
[monad (#+ do)]]
[control
+ ["." io]
["." try]
- ["ex" exception (#+ exception:)]
- ["p" parser ("#@." functor)
- ["s" code (#+ Parser)]]]
+ ["." exception (#+ exception:)]
+ ["<>" parser ("#@." functor)
+ ["<c>" code (#+ Parser)]]]
[data
["." text
["%" format (#+ format)]]]
[time
["." instant]
- ["." date (#+ Date) ("#@." order codec)]]
+ ["." date (#+ Date) ("#@." order)]]
["." macro
["." code]
- [syntax (#+ syntax:)]]
- ["." io]])
+ [syntax (#+ syntax:)]]])
-(exception: #export (must-remember {message Text} {focus (Maybe Code)})
- (format message text.new-line
- (case focus
- (#.Some focus)
- (%.code focus)
+(exception: #export (must-remember {deadline Date} {today Date} {message Text} {focus (Maybe Code)})
+ (exception.report
+ ["Deadline" (%.date deadline)]
+ ["Today" (%.date today)]
+ ["Message" message]
+ ["Code" (case focus
+ (#.Some focus)
+ (%.code focus)
- #.None
- "")))
+ #.None
+ "")]))
(def: deadline
(Parser Date)
- ($_ p.either
- (p@map (|>> instant.from-millis instant.date)
- s.int)
- (do p.monad
- [raw s.text]
+ ($_ <>.either
+ (<>@map (|>> instant.from-millis instant.date)
+ <c>.int)
+ (do <>.monad
+ [raw <c>.text]
(case (:: date.codec decode raw)
(#try.Success date)
(wrap date)
(#try.Failure message)
- (p.fail message)))))
+ (<>.fail message)))))
-(syntax: #export (remember {deadline ..deadline} {message s.text} {focus (p.maybe s.any)})
+(syntax: #export (remember {deadline ..deadline} {message <c>.text} {focus (<>.maybe <c>.any)})
(let [now (io.run instant.now)
today (instant.date now)]
(if (date@< deadline today)
@@ -51,11 +54,11 @@
#.None
(list)))
- (macro.fail (ex.construct must-remember [message focus])))))
+ (macro.fail (exception.construct ..must-remember [deadline today message focus])))))
(template [<name> <message>]
- [(syntax: #export (<name> {deadline ..deadline} {message s.text} {focus (p.maybe s.any)})
- (wrap (list (` (..remember (~ (code.text (date@encode deadline)))
+ [(syntax: #export (<name> {deadline ..deadline} {message <c>.text} {focus (<>.maybe <c>.any)})
+ (wrap (list (` (..remember (~ (code.text (%.date deadline)))
(~ (code.text (format <message> " " message)))
(~+ (case focus
(#.Some focus)
diff --git a/stdlib/source/lux/data/binary.lux b/stdlib/source/lux/data/binary.lux
index c6feeec45..33e0bdac3 100644
--- a/stdlib/source/lux/data/binary.lux
+++ b/stdlib/source/lux/data/binary.lux
@@ -133,7 +133,7 @@
(-> Nat Binary (Try I64))
(if (n.< (..!size binary) idx)
(#try.Success (!read idx binary))
- (exception.throw index-out-of-bounds [(..!size binary) idx])))
+ (exception.throw ..index-out-of-bounds [(..!size binary) idx])))
(def: #export (read/16 idx binary)
(-> Nat Binary (Try I64))
@@ -141,7 +141,7 @@
(#try.Success ($_ i64.or
(i64.left-shift 8 (!read idx binary))
(!read (n.+ 1 idx) binary)))
- (exception.throw index-out-of-bounds [(..!size binary) idx])))
+ (exception.throw ..index-out-of-bounds [(..!size binary) idx])))
(def: #export (read/32 idx binary)
(-> Nat Binary (Try I64))
@@ -151,7 +151,7 @@
(i64.left-shift 16 (!read (n.+ 1 idx) binary))
(i64.left-shift 8 (!read (n.+ 2 idx) binary))
(!read (n.+ 3 idx) binary)))
- (exception.throw index-out-of-bounds [(..!size binary) idx])))
+ (exception.throw ..index-out-of-bounds [(..!size binary) idx])))
(def: #export (read/64 idx binary)
(-> Nat Binary (Try I64))
@@ -165,7 +165,7 @@
(i64.left-shift 16 (!read (n.+ 5 idx) binary))
(i64.left-shift 8 (!read (n.+ 6 idx) binary))
(!read (n.+ 7 idx) binary)))
- (exception.throw index-out-of-bounds [(..!size binary) idx])))
+ (exception.throw ..index-out-of-bounds [(..!size binary) idx])))
(def: #export (write/8 idx value binary)
(-> Nat (I64 Any) Binary (Try Binary))
@@ -173,7 +173,7 @@
(exec (|> binary
(!write idx value))
(#try.Success binary))
- (exception.throw index-out-of-bounds [(..!size binary) idx])))
+ (exception.throw ..index-out-of-bounds [(..!size binary) idx])))
(def: #export (write/16 idx value binary)
(-> Nat (I64 Any) Binary (Try Binary))
@@ -182,7 +182,7 @@
(!write idx (i64.logic-right-shift 8 value))
(!write (n.+ 1 idx) value))
(#try.Success binary))
- (exception.throw index-out-of-bounds [(..!size binary) idx])))
+ (exception.throw ..index-out-of-bounds [(..!size binary) idx])))
(def: #export (write/32 idx value binary)
(-> Nat (I64 Any) Binary (Try Binary))
@@ -193,7 +193,7 @@
(!write (n.+ 2 idx) (i64.logic-right-shift 8 value))
(!write (n.+ 3 idx) value))
(#try.Success binary))
- (exception.throw index-out-of-bounds [(..!size binary) idx])))
+ (exception.throw ..index-out-of-bounds [(..!size binary) idx])))
(def: #export (write/64 idx value binary)
(-> Nat (I64 Any) Binary (Try Binary))
@@ -208,7 +208,7 @@
(!write (n.+ 6 idx) (i64.logic-right-shift 8 value))
(!write (n.+ 7 idx) value))
(#try.Success binary))
- (exception.throw index-out-of-bounds [(..!size binary) idx])))
+ (exception.throw ..index-out-of-bounds [(..!size binary) idx])))
(structure: #export equivalence (Equivalence Binary)
(def: (= reference sample)
@@ -280,8 +280,8 @@
## Default
(let [how-many (n.- from to)]
(..copy how-many from binary 0 (..create how-many))))))
- (exception.throw slice-out-of-bounds [size from to]))
- (exception.throw inverted-slice [size from to]))))
+ (exception.throw ..slice-out-of-bounds [size from to]))
+ (exception.throw ..inverted-slice [size from to]))))
(def: #export (slice' from binary)
(-> Nat Binary (Try Binary))
diff --git a/stdlib/source/lux/data/format/binary.lux b/stdlib/source/lux/data/format/binary.lux
index 81c8ceadd..3e1282046 100644
--- a/stdlib/source/lux/data/format/binary.lux
+++ b/stdlib/source/lux/data/format/binary.lux
@@ -21,7 +21,7 @@
["." frac]]
[text
["." encoding]
- ["%" format]]
+ ["%" format (#+ format)]]
[collection
["." list]
["." row (#+ Row) ("#@." functor)]]]])
@@ -211,9 +211,8 @@
(def: #export (list value)
(All [a] (-> (Writer a) (Writer (List a))))
(..rec
- (function (_ recur)
- (..or ..any
- (..and value recur)))))
+ (|>> (..and value)
+ (..or ..any))))
(def: #export name
(Writer Name)
diff --git a/stdlib/source/lux/data/number/i64.lux b/stdlib/source/lux/data/number/i64.lux
index f8417cfb0..97e897cc5 100644
--- a/stdlib/source/lux/data/number/i64.lux
+++ b/stdlib/source/lux/data/number/i64.lux
@@ -40,7 +40,11 @@
(def: #export (mask bits)
(-> Nat Mask)
- (|> 1 .i64 (..left-shift (n.% ..width bits)) .dec))
+ (let [multiple-of-width? (.and (.not (n.= 0 bits))
+ (n.= 0 (n.% ..width bits)))]
+ (if multiple-of-width?
+ (.i64 -1)
+ (|> 1 .i64 (..left-shift (n.% ..width bits)) .dec))))
(def: #export sign Mask (|> 1 .i64 (..left-shift 63)))
diff --git a/stdlib/source/lux/math/random.lux b/stdlib/source/lux/math/random.lux
index 90e746ca4..45944718a 100644
--- a/stdlib/source/lux/math/random.lux
+++ b/stdlib/source/lux/math/random.lux
@@ -15,10 +15,10 @@
["r" ratio]
["c" complex]
["f" frac]]
- ["." text (#+ Char) ("#;." monoid)
+ ["." text (#+ Char) ("#@." monoid)
["." unicode (#+ Segment)]]
[collection
- ["." list ("#;." fold)]
+ ["." list ("#@." fold)]
["." array (#+ Array)]
["." dictionary (#+ Dictionary)]
["." queue (#+ Queue)]
@@ -27,6 +27,12 @@
["." row (#+ Row)]
[tree
["." finger (#+ Tree)]]]]
+ [time
+ ["." instant (#+ Instant)]
+ ["." date (#+ Date)]
+ ["." duration (#+ Duration)]
+ ["." month (#+ Month)]
+ ["." day (#+ Day)]]
[type
[refinement (#+ Refiner Refined)]]])
@@ -146,7 +152,7 @@
(do ..monad
[x char-gen
xs (text char-gen (dec size))]
- (wrap (text;compose (text.from-code x) xs)))))
+ (wrap (text@compose (text.from-code x) xs)))))
(template [<name> <set>]
[(def: #export <name>
@@ -242,7 +248,7 @@
[array Array array.from-list]
[queue Queue queue.from-list]
- [stack Stack (list;fold stack.push stack.empty)]
+ [stack Stack (list@fold stack.push stack.empty)]
)
(def: #export (set Hash<a> size value-gen)
@@ -274,6 +280,45 @@
(recur [])))))
(:: ..monad wrap (dictionary.new Hash<a>))))
+(def: #export instant
+ (Random Instant)
+ (:: ..monad map instant.from-millis ..int))
+
+(def: #export date
+ (Random Date)
+ (:: ..monad map instant.date ..instant))
+
+(def: #export duration
+ (Random Duration)
+ (:: ..monad map duration.from-millis ..int))
+
+(def: #export month
+ (Random Month)
+ (let [(^open "/@.") ..monad]
+ (..either (..either (..either (/@wrap #month.January)
+ (..either (/@wrap #month.February)
+ (/@wrap #month.March)))
+ (..either (/@wrap #month.April)
+ (..either (/@wrap #month.May)
+ (/@wrap #month.June))))
+ (..either (..either (/@wrap #month.July)
+ (..either (/@wrap #month.August)
+ (/@wrap #month.September)))
+ (..either (/@wrap #month.October)
+ (..either (/@wrap #month.November)
+ (/@wrap #month.December)))))))
+
+(def: #export day
+ (Random Day)
+ (let [(^open "/@.") ..monad]
+ (..either (..either (/@wrap #day.Sunday)
+ (..either (/@wrap #day.Monday)
+ (/@wrap #day.Tuesday)))
+ (..either (..either (/@wrap #day.Wednesday)
+ (/@wrap #day.Thursday))
+ (..either (/@wrap #day.Friday)
+ (/@wrap #day.Saturday))))))
+
(def: #export (run prng calc)
(All [a] (-> PRNG (Random a) [PRNG a]))
(calc prng))
diff --git a/stdlib/source/lux/tool/compiler/default/platform.lux b/stdlib/source/lux/tool/compiler/default/platform.lux
index 1f68030bd..0d31b1f2d 100644
--- a/stdlib/source/lux/tool/compiler/default/platform.lux
+++ b/stdlib/source/lux/tool/compiler/default/platform.lux
@@ -98,16 +98,6 @@
(-> <Platform> (///generation.Operation anchor expression directive Any)))
(get@ #runtime))
- (def: (ensure-target! platform target host)
- (All <type-vars>
- (-> <Platform> Path Host (Promise (Try Any))))
- (let [system (get@ #&file-system platform)
- mkdir (: (-> Path (Promise (Try Any)))
- (file.get-directory promise.monad system))]
- (do (try.with promise.monad)
- [_ (mkdir target)]
- (mkdir (ioW.archive system host target)))))
-
(def: #export (initialize target host module expander host-analysis platform generation-bundle host-directive-bundle program extender)
(All <type-vars>
(-> Path
@@ -120,7 +110,7 @@
(///directive.Bundle anchor expression directive)
(-> expression directive)
Extender
- (Promise (Try [<State+> (Buffer directive)]))))
+ (Promise (Try [<State+> Archive (Buffer directive)]))))
(let [state (//init.state host
module
expander
@@ -132,11 +122,13 @@
program
extender)]
(do (try.with promise.monad)
- [_ (..ensure-target! platform target host)]
+ [_ (ioW.enable (get@ #&file-system platform) host target)
+ archive (ioW.thaw (get@ #&file-system platform) host target)]
(|> (do ///phase.monad
[_ ..initialize-buffer!
- _ (..compile-runtime! platform)]
- ///generation.buffer)
+ _ (..compile-runtime! platform)
+ buffer ///generation.buffer]
+ (wrap [archive buffer]))
///directive.lift-generation
(///phase.run' state)
promise@wrap)))
@@ -197,11 +189,7 @@
compilation (compiler (:coerce ///.Input input))]
(do @
[#let [dependencies (get@ #///.dependencies compilation)]
- archive+state (monad.fold @
- import!
- [archive state]
- (list.filter (bit.complement (archive.archived? archive))
- dependencies))
+ archive+state (monad.fold @ import! [archive state] dependencies)
#let [## TODO: Inline ASAP
[archive state] (:share <type-vars>
{<Platform>
@@ -220,7 +208,7 @@
state
_
- ## TODO: The "///analysis.set-current-module" below shouldn't be necessary. Remove it ASAP.
+ ## TODO: The "///directive.set-current-module" below shouldn't be necessary. Remove it ASAP.
## TODO: The context shouldn't need to be re-set either.
(|> (///directive.set-current-module module)
(///phase.run' state)
@@ -249,5 +237,7 @@
(promise@wrap (#try.Failure error)))))
(#try.Failure error)
- (promise@wrap (#try.Failure error)))))))))))
+ (do (try.with promise.monad)
+ [_ (ioW.freeze (get@ #&file-system platform) host target archive)]
+ (promise@wrap (#try.Failure error))))))))))))
)
diff --git a/stdlib/source/lux/tool/compiler/meta.lux b/stdlib/source/lux/tool/compiler/meta.lux
new file mode 100644
index 000000000..dfa57dd4c
--- /dev/null
+++ b/stdlib/source/lux/tool/compiler/meta.lux
@@ -0,0 +1,6 @@
+(.module:
+ [lux #*]
+ [//
+ [version (#+ Version)]])
+
+(def: #export version Version "0.1.0")
diff --git a/stdlib/source/lux/tool/compiler/meta/archive.lux b/stdlib/source/lux/tool/compiler/meta/archive.lux
index 6db7cc0bb..a0a4b5bf2 100644
--- a/stdlib/source/lux/tool/compiler/meta/archive.lux
+++ b/stdlib/source/lux/tool/compiler/meta/archive.lux
@@ -6,14 +6,23 @@
[control
["." try (#+ Try)]
["." exception (#+ exception:)]
- ["." function]]
+ ["." function]
+ ["<>" parser
+ ["<b>" binary (#+ Parser)]]]
[data
+ [binary (#+ Binary)]
["." product]
["." name]
- ["." text]
+ ["." text ("#@." equivalence)
+ ["%" format (#+ format)]]
+ [format
+ ["." binary (#+ Writer)]]
+ [number
+ ["n" nat]]
[collection
- ["." list]
- ["." dictionary (#+ Dictionary)]]]
+ ["." list ("#@." functor fold)]
+ ["." dictionary (#+ Dictionary)]
+ ["." set]]]
[type
abstract]
[world
@@ -22,7 +31,9 @@
["." signature (#+ Signature)]
["." key (#+ Key)]
["." descriptor (#+ Module Descriptor)]
- ["." document (#+ Document)]])
+ ["." document (#+ Document)]
+ [///
+ [version (#+ Version)]]])
(exception: #export (unknown-document {module Module}
{known-modules (List Module)})
@@ -152,4 +163,71 @@
(#try.Success archive')))
archive
(dictionary.entries (:representation additions))))
+
+ (type: Reservations (List [Module ID]))
+ (type: Frozen [Version Reservations])
+
+ (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@map (function (_ [module [id _]])
+ [module id]))
+ (list.sort (function (_ [moduleL idL] [moduleR idR])
+ (n.< idL idR)))
+ [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)
+ (-> Reservations Bit)
+ (n.= (list.size reservations)
+ (|> reservations
+ (list@map product.left)
+ (set.from-list text.hash)
+ set.size)))
+
+ (def: (correct-ids? reservations)
+ (-> Reservations Bit)
+ (n.= (list.size reservations)
+ (|> reservations
+ (list@map product.right)
+ (set.from-list n.hash)
+ set.size)))
+
+ (def: (correct-reservations? reservations)
+ (-> Reservations 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))))
)
diff --git a/stdlib/source/lux/tool/compiler/meta/io/archive.lux b/stdlib/source/lux/tool/compiler/meta/io/archive.lux
index 2a5713f4f..e71641727 100644
--- a/stdlib/source/lux/tool/compiler/meta/io/archive.lux
+++ b/stdlib/source/lux/tool/compiler/meta/io/archive.lux
@@ -15,10 +15,10 @@
["." text
["%" format (#+ format)]]]
[world
- ["." file (#+ Path File System)]]]
+ ["." file (#+ Path File Directory System)]]]
["." // (#+ Module)
- [//
- ["." archive]]])
+ ["/#" //
+ ["." archive (#+ Archive)]]])
(exception: #export (cannot-prepare {archive Path}
{module-id archive.ID}
@@ -78,14 +78,37 @@
(..artifact system host root module-id name extension)))]
(!.use (:: artifact over-write) content)))
-(def: #export (module system host root document)
- (-> (System Promise) Host Path Path (Maybe Module))
- (case (text.split-with (..archive system host root) document)
- (#.Some ["" post])
- (let [raw (text.replace-all (:: system separator) "/" post)]
- (if (text.starts-with? "/" raw)
- (text.clip' 1 raw)
- (#.Some raw)))
+(def: #export (enable system host root)
+ (-> (System Promise) Host Path (Promise (Try Any)))
+ (do (try.with promise.monad)
+ [_ (: (Promise (Try (Directory Promise)))
+ (file.get-directory promise.monad system root))
+ _ (: (Promise (Try (Directory Promise)))
+ (file.get-directory promise.monad system (..archive system host root)))]
+ (wrap [])))
+
+(def: (general-descriptor system host root)
+ (-> (System Promise) Host Path Path)
+ (format (..archive system host root)
+ (:: system separator)
+ "general-descriptor"))
+
+(def: #export (freeze system host root archive)
+ (-> (System Promise) Host Path Archive (Promise (Try Any)))
+ (do (try.with promise.monad)
+ [file (: (Promise (Try (File Promise)))
+ (file.get-file promise.monad system (..general-descriptor system host root)))]
+ (!.use (:: file over-write) (archive.export ///.version archive))))
- _
- #.None))
+(def: #export (thaw system host root)
+ (-> (System Promise) Host Path (Promise (Try Archive)))
+ (do promise.monad
+ [file (!.use (:: system file) (..general-descriptor system host root))]
+ (case file
+ (#try.Success file)
+ (do (try.with promise.monad)
+ [binary (!.use (:: file content) [])]
+ (:: promise.monad wrap (archive.import ///.version binary)))
+
+ (#try.Failure error)
+ (wrap (#try.Success archive.empty)))))
diff --git a/stdlib/source/program/compositor.lux b/stdlib/source/program/compositor.lux
index 5fb10d4ba..3e0820c10 100644
--- a/stdlib/source/program/compositor.lux
+++ b/stdlib/source/program/compositor.lux
@@ -42,8 +42,10 @@
[phase
[extension (#+ Extender)]]]]
[meta
- ["." archive (#+ Archive)
- [descriptor (#+ Module)]]]]
+ [archive (#+ Archive)
+ [descriptor (#+ Module)]]
+ [io
+ ["ioW" archive]]]]
## ["." interpreter]
]]
["." / #_
@@ -118,17 +120,19 @@
(#/cli.Compilation configuration)
(<| (or-crash! "Compilation failed:")
(do (try.with promise.monad)
- [[state runtime-buffer] (:share [<parameters>]
- {(Platform <parameters>)
- platform}
- {(Promise (Try [(directive.State+ <parameters>)
- (Buffer artifact)]))
- (platform.initialize target host (get@ #/cli.module configuration) expander host-analysis platform generation-bundle host-directive-bundle program extender)})
+ [[state archive runtime-buffer] (:share [<parameters>]
+ {(Platform <parameters>)
+ platform}
+ {(Promise (Try [(directive.State+ <parameters>)
+ Archive
+ (Buffer artifact)]))
+ (platform.initialize target host (get@ #/cli.module configuration) expander host-analysis platform generation-bundle host-directive-bundle program extender)})
[archive state] (:share [<parameters>]
{(Platform <parameters>)
platform}
{(Promise (Try [Archive (directive.State+ <parameters>)]))
- (platform.compile target partial-host-extension expander platform host configuration archive.empty extension state)})
+ (platform.compile target partial-host-extension expander platform host configuration archive extension state)})
+ _ (ioW.freeze (get@ #platform.&file-system platform) host target archive)
## _ (save-artifacts! (get@ #platform.&file-system platform) state packager,package)
## _ (cache/io.clean target ...)
]
diff --git a/stdlib/source/test/lux/abstract/codec.lux b/stdlib/source/test/lux/abstract/codec.lux
index 0793ee371..3bb35f659 100644
--- a/stdlib/source/test/lux/abstract/codec.lux
+++ b/stdlib/source/test/lux/abstract/codec.lux
@@ -6,13 +6,10 @@
["." try]]
[data
["." bit ("#@." equivalence)]
- ["%" text/format (#+ format)]
[format
- ["." json (#+ JSON)]]
- [collection
- [dictionary]]]
+ ["." json (#+ JSON)]]]
[math
- ["r" random (#+ Random)]]]
+ ["." random (#+ Random)]]]
{1
["." / (#+ Codec)
[//
@@ -36,26 +33,26 @@
(def: #export test
Test
- (do r.monad
- [expected r.bit]
- (<| (_.context (%.name (name-of /.Codec)))
- (_.test (%.name (name-of /.compose))
- (case (|> expected (:: ..codec encode) (:: ..codec decode))
- (#try.Success actual)
- (bit@= expected actual)
-
- (#try.Failure error)
- false)))))
+ (do random.monad
+ [expected random.bit]
+ (<| (_.covering /._)
+ (_.cover [/.compose]
+ (case (|> expected (:: ..codec encode) (:: ..codec decode))
+ (#try.Success actual)
+ (bit@= expected actual)
+
+ (#try.Failure error)
+ false)))))
(def: #export (spec (^open "/@.") (^open "/@.") generator)
(All [m a] (-> (Equivalence a) (Codec m a) (Random a) Test))
- (do r.monad
+ (do random.monad
[expected generator]
- (<| (_.context (%.name (name-of /.Codec)))
- (_.test "Isomorphism."
- (case (|> expected /@encode /@decode)
- (#try.Success actual)
- (/@= expected actual)
-
- (#try.Failure _)
- false)))))
+ (_.with-cover [/.Codec]
+ (_.test "Isomorphism."
+ (case (|> expected /@encode /@decode)
+ (#try.Success actual)
+ (/@= expected actual)
+
+ (#try.Failure _)
+ false)))))
diff --git a/stdlib/source/test/lux/control.lux b/stdlib/source/test/lux/control.lux
index 3a6491f25..e90ab54f1 100644
--- a/stdlib/source/test/lux/control.lux
+++ b/stdlib/source/test/lux/control.lux
@@ -12,6 +12,7 @@
["#." pipe]
["#." reader]
["#." region]
+ ["#." remember]
["#." state]
["#." thread]
["#." writer]
@@ -72,6 +73,7 @@
/pipe.test
/reader.test
/region.test
+ /remember.test
/state.test
/thread.test
/writer.test
diff --git a/stdlib/source/test/lux/control/remember.lux b/stdlib/source/test/lux/control/remember.lux
new file mode 100644
index 000000000..0b5537ef0
--- /dev/null
+++ b/stdlib/source/test/lux/control/remember.lux
@@ -0,0 +1,122 @@
+(.module:
+ [lux #*
+ ["_" test (#+ Test)]
+ [abstract
+ ["." monad (#+ do)]]
+ [control
+ ["." io]
+ ["." try (#+ Try)]
+ ["." exception]
+ [parser
+ ["<c>" code]]]
+ [data
+ ["." product]
+ ["." text
+ ["%" format (#+ format)]]]
+ [math
+ ["." random (#+ Random) ("#@." monad)]]
+ [time
+ ["." date (#+ Date)]
+ ["." instant]
+ ["." duration]]
+ ["." macro
+ ["." code]
+ ["." syntax (#+ syntax:)]]]
+ {1
+ ["." /]})
+
+(def: deadline (Random Date) random.date)
+(def: message (Random Text) (random@map %.nat random.nat))
+(def: focus (Random Code) (random@map code.text (random.ascii/upper-alpha 10)))
+
+(def: (to-remember macro deadline message focus)
+ (-> Name Date Text (Maybe Code) Code)
+ (` ((~ (code.identifier macro))
+ (~ (code.text (%.date deadline)))
+ (~ (code.text message))
+ (~+ (case focus
+ #.None (list)
+ (#.Some focus) (list focus))))))
+
+(def: (try computation)
+ (All [a] (-> (Meta a) (Meta (Try a))))
+ (function (_ compiler)
+ (case (computation compiler)
+ (#try.Success [compiler output])
+ (#try.Success [compiler (#try.Success output)])
+
+ (#try.Failure error)
+ (#try.Success [compiler (#try.Failure error)]))))
+
+(def: (test-failure deadline message focus failure)
+ (-> Date Text (Maybe Code) Text Bit)
+ (and (text.contains? (%.date deadline) failure)
+ (text.contains? message failure)
+ (case focus
+ #.None
+ true
+
+ (#.Some focus)
+ (text.contains? (%.code focus) failure))))
+
+(syntax: (test-macro {macro <c>.identifier} {extra <c>.text})
+ (let [now (io.run instant.now)
+ today (instant.date now)
+ yesterday (instant.date (instant.shift (duration.inverse duration.week) now))
+ tomorrow (instant.date (instant.shift duration.week now))
+ prng (random.pcg-32 [123 (instant.to-millis now)])
+ message (product.right (random.run prng ..message))
+ expected (product.right (random.run prng ..focus))]
+ (do @
+ [should-fail0 (..try (macro.expand (to-remember macro yesterday message #.None)))
+ should-fail1 (..try (macro.expand (to-remember macro yesterday message (#.Some expected))))
+ should-succeed0 (..try (macro.expand (to-remember macro tomorrow message #.None)))
+ should-succeed1 (..try (macro.expand (to-remember macro tomorrow message (#.Some expected))))]
+ (wrap (list (code.bit (and (case should-fail0
+ (#try.Failure error)
+ (and (test-failure yesterday message #.None error)
+ (text.contains? extra error))
+
+ _
+ false)
+ (case should-fail1
+ (#try.Failure error)
+ (and (test-failure yesterday message (#.Some expected) error)
+ (text.contains? extra error))
+
+ _
+ false)
+ (case should-succeed0
+ (^ (#try.Success (list)))
+ true
+
+ _
+ false)
+ (case should-succeed1
+ (^ (#try.Success (list actual)))
+ (is? expected actual)
+
+ _
+ false)
+ )))))))
+
+(def: #export test
+ Test
+ (<| (_.covering /._)
+ (do random.monad
+ [deadline ..deadline
+ message ..message
+ focus ..focus]
+ ($_ _.and
+ (_.cover [/.must-remember]
+ (and (test-failure deadline message #.None
+ (exception.construct /.must-remember [deadline deadline message #.None]))
+ (test-failure deadline message (#.Some focus)
+ (exception.construct /.must-remember [deadline deadline message (#.Some focus)]))))
+ (_.cover [/.remember]
+ (..test-macro /.remember ""))
+ (_.cover [/.to-do]
+ (..test-macro /.to-do "TODO"))
+ (_.cover [/.fix-me]
+ (..test-macro /.fix-me "FIXME"))
+ ))))
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-06 21:20:09 +0000