From d636f97db32f0ca3aa1705c5290afc07314adc53 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Tue, 21 Apr 2020 02:53:23 -0400 Subject: Now caching the reservations from the archive. --- stdlib/source/lux/control/parser/binary.lux | 11 +- stdlib/source/lux/control/remember.lux | 49 +++++---- stdlib/source/lux/data/binary.lux | 20 ++-- stdlib/source/lux/data/format/binary.lux | 7 +- stdlib/source/lux/data/number/i64.lux | 6 +- stdlib/source/lux/math/random.lux | 53 ++++++++- .../source/lux/tool/compiler/default/platform.lux | 32 ++---- stdlib/source/lux/tool/compiler/meta.lux | 6 + stdlib/source/lux/tool/compiler/meta/archive.lux | 88 ++++++++++++++- .../source/lux/tool/compiler/meta/io/archive.lux | 49 ++++++--- stdlib/source/program/compositor.lux | 22 ++-- stdlib/source/test/lux/abstract/codec.lux | 45 ++++---- stdlib/source/test/lux/control.lux | 2 + stdlib/source/test/lux/control/remember.lux | 122 +++++++++++++++++++++ 14 files changed, 393 insertions(+), 119 deletions(-) create mode 100644 stdlib/source/lux/tool/compiler/meta.lux create mode 100644 stdlib/source/test/lux/control/remember.lux (limited to 'stdlib/source') 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 [ ] [(def: #export @@ -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) + ["" 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) + .int) + (do <>.monad + [raw .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 .text} {focus (<>.maybe .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 [ ] - [(syntax: #export ( {deadline ..deadline} {message s.text} {focus (p.maybe s.any)}) - (wrap (list (` (..remember (~ (code.text (date@encode deadline))) + [(syntax: #export ( {deadline ..deadline} {message .text} {focus (<>.maybe .any)}) + (wrap (list (` (..remember (~ (code.text (%.date deadline))) (~ (code.text (format " " 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 [ ] [(def: #export @@ -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 size value-gen) @@ -274,6 +280,45 @@ (recur []))))) (:: ..monad wrap (dictionary.new Hash)))) +(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 @@ (-> (///generation.Operation anchor expression directive Any))) (get@ #runtime)) - (def: (ensure-target! platform target host) - (All - (-> 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 (-> Path @@ -120,7 +110,7 @@ (///directive.Bundle anchor expression directive) (-> expression directive) Extender - (Promise (Try [ (Buffer directive)])))) + (Promise (Try [ 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 { @@ -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 + ["" 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 .text + (.list (<>.and .text .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] (.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 [] - {(Platform ) - platform} - {(Promise (Try [(directive.State+ ) - (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 [] + {(Platform ) + platform} + {(Promise (Try [(directive.State+ ) + 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 [] {(Platform ) platform} {(Promise (Try [Archive (directive.State+ )])) - (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 + ["" 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 .identifier} {extra .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")) + )))) -- cgit v1.2.3