diff options
| author | Eduardo Julian | 2020-04-21 02:53:23 -0400 | 
|---|---|---|
| committer | Eduardo Julian | 2020-04-21 02:53:23 -0400 | 
| commit | d636f97db32f0ca3aa1705c5290afc07314adc53 (patch) | |
| tree | 28669a028d9c27fe53ce433c76d40677b42b144a /stdlib | |
| parent | f6a2fe158979230dcf2d271981ff34be39c7bffc (diff) | |
Now caching the reservations from the archive.
Diffstat (limited to '')
| -rw-r--r-- | stdlib/source/lux/control/parser/binary.lux | 11 | ||||
| -rw-r--r-- | stdlib/source/lux/control/remember.lux | 49 | ||||
| -rw-r--r-- | stdlib/source/lux/data/binary.lux | 20 | ||||
| -rw-r--r-- | stdlib/source/lux/data/format/binary.lux | 7 | ||||
| -rw-r--r-- | stdlib/source/lux/data/number/i64.lux | 6 | ||||
| -rw-r--r-- | stdlib/source/lux/math/random.lux | 53 | ||||
| -rw-r--r-- | stdlib/source/lux/tool/compiler/default/platform.lux | 32 | ||||
| -rw-r--r-- | stdlib/source/lux/tool/compiler/meta.lux | 6 | ||||
| -rw-r--r-- | stdlib/source/lux/tool/compiler/meta/archive.lux | 88 | ||||
| -rw-r--r-- | stdlib/source/lux/tool/compiler/meta/io/archive.lux | 49 | ||||
| -rw-r--r-- | stdlib/source/program/compositor.lux | 22 | ||||
| -rw-r--r-- | stdlib/source/test/lux/abstract/codec.lux | 45 | ||||
| -rw-r--r-- | stdlib/source/test/lux/control.lux | 2 | ||||
| -rw-r--r-- | stdlib/source/test/lux/control/remember.lux | 122 | 
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")) +            )))) | 
