diff options
Diffstat (limited to '')
10 files changed, 202 insertions, 30 deletions
diff --git a/stdlib/source/lux/control/concurrency/frp.lux b/stdlib/source/lux/control/concurrency/frp.lux index 3dc596a91..a9beb4a0e 100644 --- a/stdlib/source/lux/control/concurrency/frp.lux +++ b/stdlib/source/lux/control/concurrency/frp.lux @@ -204,7 +204,7 @@ (#.Some [head tail]) (do @ [init' (f head init)] - (folds f init' tail))))) + (wrap (#.Some [init (folds f init' tail)])))))) (def: #export (poll milli-seconds action) (All [a] diff --git a/stdlib/source/lux/time/instant.lux b/stdlib/source/lux/time/instant.lux index a8d308951..bd378016a 100644 --- a/stdlib/source/lux/time/instant.lux +++ b/stdlib/source/lux/time/instant.lux @@ -23,7 +23,7 @@ [type abstract]] [// - ["." duration] + ["." duration (#+ Duration)] ["." date (#+ Date)] ["." month (#+ Month)] ["." day (#+ Day)]]) @@ -41,19 +41,19 @@ (|>> :representation)) (def: #export (span from to) - (-> Instant Instant duration.Duration) + (-> Instant Instant Duration) (duration.from-millis (i.- (:representation from) (:representation to)))) (def: #export (shift duration instant) - (-> duration.Duration Instant Instant) + (-> Duration Instant Instant) (:abstraction (i.+ (duration.to-millis duration) (:representation instant)))) (def: #export (relative instant) - (-> Instant duration.Duration) + (-> Instant Duration) (|> instant :representation duration.from-millis)) (def: #export (absolute offset) - (-> duration.Duration Instant) + (-> Duration Instant) (|> offset duration.to-millis :abstraction)) (structure: #export equivalence (Equivalence Instant) @@ -94,7 +94,7 @@ (def: epoch-year Int +1970) (def: (find-year now) - (-> Instant [Int duration.Duration]) + (-> Instant [Int Duration]) (loop [reference epoch-year time-left (relative now)] (let [year (if (leap-year? reference) @@ -108,7 +108,7 @@ )))) (def: (find-month months time) - (-> (Row Nat) duration.Duration [Nat duration.Duration]) + (-> (Row Nat) Duration [Nat Duration]) (if (order.>= duration.order duration.empty time) (row@fold (function (_ month-days [current-month time-left]) (let [month-duration (duration.scale-up month-days duration.day)] @@ -132,7 +132,7 @@ (i@encode value))) (def: (adjust-negative space duration) - (-> duration.Duration duration.Duration duration.Duration) + (-> Duration Duration Duration) (if (duration.negative? duration) (duration.merge space duration) duration)) @@ -149,7 +149,7 @@ (def: days-up-to-epoch Int +719468) (def: (extract-date instant) - (-> Instant [[Int Int Int] duration.Duration]) + (-> Instant [[Int Int Int] Duration]) (let [offset (relative instant) seconds (duration.query duration.second offset) z (|> seconds (i./ seconds-per-day) (i.+ days-up-to-epoch)) diff --git a/stdlib/source/lux/tool/compiler/default/platform.lux b/stdlib/source/lux/tool/compiler/default/platform.lux index 26a301f86..76939bb08 100644 --- a/stdlib/source/lux/tool/compiler/default/platform.lux +++ b/stdlib/source/lux/tool/compiler/default/platform.lux @@ -16,7 +16,7 @@ ["%" format (#+ format)]] [collection [dictionary (#+ Dictionary)] - ["." row] + ["." row ("#@." fold)] ["." set] ["." list ("#@." monoid)]] [format @@ -210,6 +210,28 @@ _ (..cache-module platform host target 0 extension payload)] (wrap [state archive]))))) + (def: module-compilation-log + (All [<type-vars>] + (-> <State+> Text)) + (|>> (get@ [#extension.state + #///directive.generation + #///directive.state + #extension.state + #///generation.log]) + (row@fold (function (_ right left) + (format left text.new-line right)) + ""))) + + (def: with-reset-log + (All [<type-vars>] + (-> <State+> <State+>)) + (set@ [#extension.state + #///directive.generation + #///directive.state + #extension.state + #///generation.log] + row.empty)) + (def: #export (compile target partial-host-extension expander platform host configuration archive extension state) (All [<type-vars>] (-> Text Text Expander <Platform> Host Configuration Archive Text <State+> (Promise (Try [Archive <State+>])))) @@ -274,11 +296,13 @@ (#.Right [[descriptor document] output]) (do (try.with promise.monad) - [#let [descriptor (set@ #descriptor.references (set.from-list text.hash all-dependencies) descriptor)] + [#let [_ (log! (..module-compilation-log state)) + descriptor (set@ #descriptor.references (set.from-list text.hash all-dependencies) descriptor)] _ (..cache-module platform host target module-id extension [[descriptor document] output])] (case (archive.add module [descriptor document] archive) (#try.Success archive) - (wrap [archive state]) + (wrap [archive + (..with-reset-log state)]) (#try.Failure error) (promise@wrap (#try.Failure error))))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/generation.lux b/stdlib/source/lux/tool/compiler/language/lux/generation.lux index 336e4913a..41dcdd990 100644 --- a/stdlib/source/lux/tool/compiler/language/lux/generation.lux +++ b/stdlib/source/lux/tool/compiler/language/lux/generation.lux @@ -1,5 +1,5 @@ (.module: - [lux (#- Module) + [lux (#- Module log!) [abstract [monad (#+ do)]] [control @@ -66,7 +66,8 @@ #buffer (Maybe (Buffer directive)) #registry artifact.Registry #counter Nat - #context (Maybe artifact.ID)}) + #context (Maybe artifact.ID) + #log (Row Text)}) (template [<special> <general>] [(type: #export (<special> anchor expression directive) @@ -90,7 +91,8 @@ #buffer #.None #registry artifact.empty #counter 0 - #context #.None}) + #context #.None + #log row.empty}) (def: #export empty-buffer Buffer row.empty) @@ -303,3 +305,11 @@ (wrap [[bundle' (set@ #context (get@ #context state) state')] [[module-id id] output]]))))) + +(def: #export (log! message) + (All [anchor expression directive a] + (-> Text (Operation anchor expression directive Any))) + (function (_ [bundle state]) + (#try.Success [[bundle + (update@ #log (row.add message) state)] + []]))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/directive/jvm.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/directive/jvm.lux index 4db15e8e6..cb3277591 100644 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/directive/jvm.lux +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/directive/jvm.lux @@ -44,6 +44,7 @@ [compiler ["." analysis] ["." synthesis] + ["." generation] ["." directive (#+ Handler Bundle)] ["." phase [analysis @@ -291,7 +292,8 @@ ## (list@map ..field-definition fields) ## (list) ## TODO: Add methods ## (row.row))])) - #let [_ (log! (format "Class " name))]] + _ (directive.lift-generation + (generation.log! (format "Class " name)))] (wrap directive.no-requirements)))])) (def: #export bundle diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/directive/lux.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/directive/lux.lux index f7099d2c4..24d059031 100644 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/directive/lux.lux +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/directive/lux.lux @@ -197,6 +197,12 @@ [(///analysis.bundle eval host-analysis)])) state)]))) +(def: (announce-definition! name) + (All [anchor expression directive] + (-> Name (Operation anchor expression directive Any))) + (/////directive.lift-generation + (/////generation.log! (format "Definition " (%.name name))))) + (def: (lux::def expander host-analysis) (-> Expander /////analysis.Bundle Handler) (function (_ extension-name phase archive inputsC+) @@ -210,8 +216,8 @@ [_ annotationsT annotations] (evaluate! archive Code annotationsC) _ (/////directive.lift-analysis (module.define short-name (#.Right [exported? type (:coerce Code annotations) value]))) - #let [_ (log! (format "Definition " (%.name full-name)))] - _ (..refresh expander host-analysis)] + _ (..refresh expander host-analysis) + _ (..announce-definition! full-name)] (wrap /////directive.no-requirements)) _ @@ -233,8 +239,8 @@ (do phase.monad [_ (module.define short-name (#.Right [exported? type annotations value]))] (module.declare-tags tags exported? (:coerce Type value)))) - #let [_ (log! (format "Definition " (%.name full-name)))] - _ (..refresh expander host-analysis)] + _ (..refresh expander host-analysis) + _ (..announce-definition! full-name)] (wrap /////directive.no-requirements)))])) (def: imports @@ -317,7 +323,8 @@ handler} {<type> (:assume handlerV)})) - #let [_ (log! (format <description> " " (%.text (:coerce Text name))))]] + _ (/////directive.lift-generation + (/////generation.log! (format <description> " " (%.text (:coerce Text name)))))] (wrap /////directive.no-requirements)) _ diff --git a/stdlib/source/test/lux/control.lux b/stdlib/source/test/lux/control.lux index e90ab54f1..b393e1325 100644 --- a/stdlib/source/test/lux/control.lux +++ b/stdlib/source/test/lux/control.lux @@ -17,10 +17,11 @@ ["#." thread] ["#." writer] [concurrency + ["#." actor] ["#." atom] - ["#." promise] ["#." frp] - ["#." actor] + ["#." process] + ["#." promise] ["#." stm]] ["#." parser #_ ["#/." text] @@ -34,10 +35,11 @@ (def: concurrency Test ($_ _.and + /actor.test /atom.test - /promise.test /frp.test - /actor.test + /process.test + /promise.test /stm.test )) diff --git a/stdlib/source/test/lux/control/concatenative.lux b/stdlib/source/test/lux/control/concatenative.lux index 6701916fc..52cd5d214 100644 --- a/stdlib/source/test/lux/control/concatenative.lux +++ b/stdlib/source/test/lux/control/concatenative.lux @@ -146,11 +146,94 @@ |inc| (/.apply/1 inc) |test| (/.apply/1 (|>> (n.- start) (n.< distance)))]] ($_ _.and - (_.cover [/.call] + (_.cover [/.call /.apply/1] (n.= (inc sample) (||> (/.push sample) (/.push (/.apply/1 inc)) /.call))) + (_.cover [/.apply/2] + (n.= (n.+ sample sample) + (||> (/.push sample) + (/.push sample) + (/.push (/.apply/2 n.+)) + /.call))) + (_.cover [/.apply/3] + (n.= ($_ n.+ sample sample sample) + (||> (/.push sample) + (/.push sample) + (/.push sample) + (/.push (/.apply/3 (function (_ i0 i1 i2) + ($_ n.+ i0 i1 i2)))) + /.call))) + (_.cover [/.apply/4] + (n.= ($_ n.+ sample sample sample sample) + (||> (/.push sample) + (/.push sample) + (/.push sample) + (/.push sample) + (/.push (/.apply/4 (function (_ i0 i1 i2 i3) + ($_ n.+ i0 i1 i2 i3)))) + /.call))) + (_.cover [/.apply/5] + (n.= ($_ n.+ sample sample sample sample sample) + (||> (/.push sample) + (/.push sample) + (/.push sample) + (/.push sample) + (/.push sample) + (/.push (/.apply/5 (function (_ i0 i1 i2 i3 i4) + ($_ n.+ i0 i1 i2 i3 i4)))) + /.call))) + (_.cover [/.apply/6] + (n.= ($_ n.+ sample sample sample sample sample sample) + (||> (/.push sample) + (/.push sample) + (/.push sample) + (/.push sample) + (/.push sample) + (/.push sample) + (/.push (/.apply/6 (function (_ i0 i1 i2 i3 i4 i5) + ($_ n.+ i0 i1 i2 i3 i4 i5)))) + /.call))) + (_.cover [/.apply/7] + (n.= ($_ n.+ sample sample sample sample sample sample sample) + (||> (/.push sample) + (/.push sample) + (/.push sample) + (/.push sample) + (/.push sample) + (/.push sample) + (/.push sample) + (/.push (/.apply/7 (function (_ i0 i1 i2 i3 i4 i5 i6) + ($_ n.+ i0 i1 i2 i3 i4 i5 i6)))) + /.call))) + (_.cover [/.apply/8] + (n.= ($_ n.+ sample sample sample sample sample sample sample sample) + (||> (/.push sample) + (/.push sample) + (/.push sample) + (/.push sample) + (/.push sample) + (/.push sample) + (/.push sample) + (/.push sample) + (/.push (/.apply/8 (function (_ i0 i1 i2 i3 i4 i5 i6 i7) + ($_ n.+ i0 i1 i2 i3 i4 i5 i6 i7)))) + /.call))) + (_.cover [/.apply] + (n.= ($_ n.+ sample sample sample sample sample sample sample sample sample) + (||> (/.push sample) + (/.push sample) + (/.push sample) + (/.push sample) + (/.push sample) + (/.push sample) + (/.push sample) + (/.push sample) + (/.push sample) + (/.push ((/.apply 9) (function (_ i0 i1 i2 i3 i4 i5 i6 i7 i8) + ($_ n.+ i0 i1 i2 i3 i4 i5 i6 i7 i8)))) + /.call))) (_.cover [/.if] (n.= (if choice (inc sample) @@ -219,7 +302,7 @@ Test (do random.monad [sample random.nat] - (_.cover [/.word:] + (_.cover [/.word: /.=> /.||>] (n.= (n.* sample sample) (||> (/.push sample) ..square))))) diff --git a/stdlib/source/test/lux/control/concurrency/frp.lux b/stdlib/source/test/lux/control/concurrency/frp.lux index f7f7427b6..8752a195f 100644 --- a/stdlib/source/test/lux/control/concurrency/frp.lux +++ b/stdlib/source/test/lux/control/concurrency/frp.lux @@ -13,8 +13,6 @@ ["." exception] ["." io (#+ IO io)]] [data - [text - ["%" format (#+ format)]] [number ["n" nat]] [collection diff --git a/stdlib/source/test/lux/control/concurrency/process.lux b/stdlib/source/test/lux/control/concurrency/process.lux new file mode 100644 index 000000000..165fbad93 --- /dev/null +++ b/stdlib/source/test/lux/control/concurrency/process.lux @@ -0,0 +1,46 @@ +(.module: + [lux #* + ["_" test (#+ Test)] + [abstract + [monad (#+ do)]] + [control + ["." io]] + [data + [number + ["n" nat] + ["i" int]]] + [time + ["." instant (#+ Instant)] + ["." duration]] + [math + ["." random]]] + {1 + ["." / + [// + ["." atom (#+ Atom)] + ["." promise]]]}) + +(def: #export test + Test + (<| (_.covering /._) + (do random.monad + [dummy random.nat + expected random.nat + delay (|> random.nat (:: @ map (n.% 100)))] + ($_ _.and + (_.cover [/.parallelism] + (n.> 0 /.parallelism)) + (wrap (do promise.monad + [reference-time (promise.future instant.now) + #let [box (atom.atom [reference-time dummy])] + _ (promise.future + (/.schedule delay (do io.monad + [execution-time instant.now] + (atom.write [execution-time expected] box)))) + _ (promise.wait delay) + [execution-time actual] (promise.future (atom.read box))] + (_.claim [/.schedule] + (and (i.>= (.int delay) + (duration.to-millis (instant.span reference-time execution-time))) + (n.= expected actual))))) + )))) |