diff options
Diffstat (limited to '')
16 files changed, 342 insertions, 155 deletions
diff --git a/stdlib/source/documentation/lux/tool/compiler/phase.lux b/stdlib/source/documentation/lux/tool/compiler/phase.lux index 088873701..0ef45f8db 100644 --- a/stdlib/source/documentation/lux/tool/compiler/phase.lux +++ b/stdlib/source/documentation/lux/tool/compiler/phase.lux @@ -20,14 +20,13 @@ ($.default /.Wrapper) ($.default /.result') ($.default /.result) - ($.default /.get_state) - ($.default /.set_state) + ($.default /.state) + ($.default /.with) ($.default /.sub) ($.default /.failure) ($.default /.except) ($.default /.lifted) ($.default /.assertion) ($.default /.identity) - ($.default /.composite) - ($.default /.timed)] + ($.default /.composite)] [])) diff --git a/stdlib/source/library/lux/math/number.lux b/stdlib/source/library/lux/math/number.lux index 48ce42fbe..d52fc62e0 100644 --- a/stdlib/source/library/lux/math/number.lux +++ b/stdlib/source/library/lux/math/number.lux @@ -62,6 +62,6 @@ {try.#Failure <error>}))] [bin /nat.binary /int.binary /rev.binary /frac.binary "Invalid binary syntax."] - [oct /nat.octal /int.octal /rev.octal /frac.octal "Invalid octal syntax."] - [hex /nat.hex /int.hex /rev.hex /frac.hex "Invalid hexadecimal syntax."] + [oct /nat.octal /int.octal /rev.octal /frac.octal "Invalid octal syntax."] + [hex /nat.hex /int.hex /rev.hex /frac.hex "Invalid hexadecimal syntax."] ) diff --git a/stdlib/source/library/lux/math/random.lux b/stdlib/source/library/lux/math/random.lux index 6eab77fef..13bac71cf 100644 --- a/stdlib/source/library/lux/math/random.lux +++ b/stdlib/source/library/lux/math/random.lux @@ -126,7 +126,7 @@ (template [<name> <type> <cast>] [(def: .public <name> (Random <type>) - (# ..monad each <cast> ..i64))] + (# ..functor each <cast> ..i64))] [nat Nat .nat] [int Int .int] @@ -135,13 +135,13 @@ (def: .public frac (Random Frac) - (# ..monad each (|>> .i64 f.of_bits) ..nat)) + (# ..functor each (|>> .i64 f.of_bits) ..nat)) (def: .public safe_frac (Random Frac) (let [mantissa_range (.int (i64.left_shifted 53 1)) mantissa_max (i.frac (-- mantissa_range))] - (# ..monad each + (# ..functor each (|>> (i.% mantissa_range) i.frac (f./ mantissa_max)) @@ -155,7 +155,7 @@ in_range (: (-> Char Char) (|>> (n.% size) (n.+ start)))] (|> ..nat - (# ..monad each in_range) + (# ..functor each in_range) (..only (unicode.member? set))))) (def: .public (text char_gen size) @@ -297,19 +297,19 @@ (def: .public instant (Random Instant) - (# ..monad each instant.of_millis ..int)) + (# ..functor each instant.of_millis ..int)) (def: .public date (Random Date) - (# ..monad each instant.date ..instant)) + (# ..functor each instant.date ..instant)) (def: .public time (Random Time) - (# ..monad each instant.time ..instant)) + (# ..functor each instant.time ..instant)) (def: .public duration (Random Duration) - (# ..monad each duration.of_millis ..int)) + (# ..functor each duration.of_millis ..int)) (def: .public month (Random Month) diff --git a/stdlib/source/library/lux/target/jvm/encoding/signed.lux b/stdlib/source/library/lux/target/jvm/encoding/signed.lux index dee539eae..027174fd1 100644 --- a/stdlib/source/library/lux/target/jvm/encoding/signed.lux +++ b/stdlib/source/library/lux/target/jvm/encoding/signed.lux @@ -60,8 +60,8 @@ (def: .public <constructor> (-> Int (Try <name>)) - (let [positive (|> <bytes> (n.* i64.bits_per_byte) i64.mask) - negative (|> positive .int (i.right_shifted 1) i64.not)] + (let [positive (:representation <maximum>) + negative (|> <bytes> (n.* i64.bits_per_byte) i64.mask i64.not)] (function (_ value) (if (i.= (if (i.< +0 value) (i64.or negative value) diff --git a/stdlib/source/library/lux/target/ruby.lux b/stdlib/source/library/lux/target/ruby.lux index df112f23f..22cad3f00 100644 --- a/stdlib/source/library/lux/target/ruby.lux +++ b/stdlib/source/library/lux/target/ruby.lux @@ -469,13 +469,10 @@ <inputs> (arity_inputs <arity>) <types> (arity_types <arity>) <definitions> (template.spliced <function>+)] - (def: .public (<apply> function <inputs>) - (-> Expression <types> Computation) - (..apply/* (.list <inputs>) {.#None} function)) - (template [<function>] - [(`` (def: .public (~~ (template.symbol [<function> "/" <arity>])) - (<apply> (..local <function>))))] + [(`` (def: .public ((~~ (template.symbol [<function> "/" <arity>])) <inputs>) + (-> <types> Computation) + (..apply/* (.list <inputs>) {.#None} (..local <function>))))] <definitions>))] @@ -490,11 +487,10 @@ ["alias_method"]]] ) -(def: .public throw/1 +(def: .public (throw/1 error) (-> Expression Statement) - (|>> (..apply/1 (..local "throw")) - ..statement)) + (..statement (..apply/* (list error) {.#None} (..local "throw")))) (def: .public (throw/2 tag value) (-> Expression Expression Statement) - (..statement (..apply/2 (..local "throw") tag value))) + (..statement (..apply/* (list tag value) {.#None} (..local "throw")))) diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/directive.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/directive.lux index 23123a8c5..fefafe199 100644 --- a/stdlib/source/library/lux/tool/compiler/language/lux/phase/directive.lux +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/directive.lux @@ -80,7 +80,7 @@ (let [analysis (//analysis.phase expander)] (function (again archive code) (do [! //.monad] - [state //.get_state + [state //.state .let [compiler_eval (meta_eval archive (value@ [//extension.#state /.#analysis /.#state //extension.#bundle] state) (evaluation.evaluator expander @@ -88,7 +88,7 @@ (value@ [//extension.#state /.#generation /.#state] state) (value@ [//extension.#state /.#generation /.#phase] state))) extension_eval (:as Eval (wrapper (:expected compiler_eval)))] - _ (//.set_state (with@ [//extension.#state /.#analysis /.#state //extension.#state .#eval] extension_eval state))] + _ (//.with (with@ [//extension.#state /.#analysis /.#state //extension.#state .#eval] extension_eval state))] (case code (^ [_ {.#Form (list& [_ {.#Text name}] inputs)}]) (//extension.apply archive again [name inputs]) diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/directive/jvm.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/directive/jvm.lux index 5b49ae38a..b7693e24b 100644 --- a/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/directive/jvm.lux +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/directive/jvm.lux @@ -287,7 +287,7 @@ .let [selfT (jvm.inheritance_relationship_type {.#Primitive name (list#each product.right parameters)} super_classT super_interfaceT+)] - state (extension.lifted phase.get_state) + state (extension.lifted phase.state) .let [analyse (value@ [directive.#analysis directive.#phase] state) synthesize (value@ [directive.#synthesis directive.#phase] state) generate (value@ [directive.#generation directive.#phase] state)] diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/directive/lux.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/directive/lux.lux index 49e889381..965a9e641 100644 --- a/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/directive/lux.lux +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/directive/lux.lux @@ -93,7 +93,7 @@ (All (_ anchor expression directive) (-> Archive Type Code (Operation anchor expression directive [Type expression Any]))) (do phase.monad - [state (///.lifted phase.get_state) + [state (///.lifted phase.state) .let [analyse (value@ [/////directive.#analysis /////directive.#phase] state) synthesize (value@ [/////directive.#synthesis /////directive.#phase] state) generate (value@ [/////directive.#generation /////directive.#phase] state)] @@ -131,7 +131,7 @@ (-> Archive Symbol (Maybe Type) Code (Operation anchor expression directive [Type expression Any]))) (do [! phase.monad] - [state (///.lifted phase.get_state) + [state (///.lifted phase.state) .let [analyse (value@ [/////directive.#analysis /////directive.#phase] state) synthesize (value@ [/////directive.#synthesis /////directive.#phase] state) generate (value@ [/////directive.#generation /////directive.#phase] state)] @@ -185,7 +185,7 @@ (-> Archive Text Type Code (Operation anchor expression directive [expression Any]))) (do phase.monad - [state (///.lifted phase.get_state) + [state (///.lifted phase.state) .let [analyse (value@ [/////directive.#analysis /////directive.#phase] state) synthesize (value@ [/////directive.#synthesis /////directive.#phase] state) generate (value@ [/////directive.#generation /////directive.#phase] state)] @@ -209,19 +209,19 @@ (All (_ anchor expression directive) (-> Expander /////analysis.Bundle (Operation anchor expression directive Any))) (do phase.monad - [[bundle state] phase.get_state + [[bundle state] phase.state .let [eval (/////analysis/evaluation.evaluator expander (value@ [/////directive.#synthesis /////directive.#state] state) (value@ [/////directive.#generation /////directive.#state] state) (value@ [/////directive.#generation /////directive.#phase] state)) previous_analysis_extensions (value@ [/////directive.#analysis /////directive.#state ///.#bundle] state)]] - (phase.set_state [bundle - (revised@ [/////directive.#analysis /////directive.#state] - (: (-> /////analysis.State+ /////analysis.State+) - (|>> product.right - [(|> previous_analysis_extensions - (dictionary.merged (///analysis.bundle eval host_analysis)))])) - state)]))) + (phase.with [bundle + (revised@ [/////directive.#analysis /////directive.#state] + (: (-> /////analysis.State+ /////analysis.State+) + (|>> product.right + [(|> previous_analysis_extensions + (dictionary.merged (///analysis.bundle eval host_analysis)))])) + state)]))) (def: (announce_definition! short type) (All (_ anchor expression directive) @@ -509,7 +509,7 @@ (case inputsC+ (^ (list programC)) (do phase.monad - [state (///.lifted phase.get_state) + [state (///.lifted phase.state) .let [analyse (value@ [/////directive.#analysis /////directive.#phase] state) synthesize (value@ [/////directive.#synthesis /////directive.#phase] state) generate (value@ [/////directive.#generation /////directive.#phase] state)] diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/runtime.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/runtime.lux index ece1fa89e..b59f57dc5 100644 --- a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/runtime.lux +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/runtime.lux @@ -98,7 +98,7 @@ 0) (def: .public class - (type.class (%.nat ..artifact_id) (list))) + (type.class (class_name [0 ..artifact_id]) (list))) (def: procedure (-> Text (Type category.Method) (Bytecode Any)) diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/version.lux b/stdlib/source/library/lux/tool/compiler/language/lux/version.lux index 25f68450d..cc044938c 100644 --- a/stdlib/source/library/lux/tool/compiler/language/lux/version.lux +++ b/stdlib/source/library/lux/tool/compiler/language/lux/version.lux @@ -6,4 +6,4 @@ (def: .public version Version - 00,07,00) + 00,06,06) diff --git a/stdlib/source/library/lux/tool/compiler/phase.lux b/stdlib/source/library/lux/tool/compiler/phase.lux index 9815f9eb7..a52f8b796 100644 --- a/stdlib/source/library/lux/tool/compiler/phase.lux +++ b/stdlib/source/library/lux/tool/compiler/phase.lux @@ -1,35 +1,58 @@ (.using - [library - [lux "*" - ["[0]" debug] - [abstract - [monad {"+" Monad do}]] - [control - ["[0]" state] - ["[0]" try {"+" Try} ("[1]#[0]" functor)] - ["ex" exception {"+" Exception exception:}] - ["[0]" io] - [parser - ["<[0]>" code]]] - [data - ["[0]" product] - ["[0]" text - ["%" format {"+" format}]]] - [time - ["[0]" instant] - ["[0]" duration]] - [macro - [syntax {"+" syntax:}]]]] - [// - [meta - [archive {"+" Archive}]]]) + [library + [lux "*" + ["[0]" debug] + [abstract + [functor {"+" Functor}] + [monad {"+" Monad do}]] + [control + ["[0]" state] + ["[0]" try {"+" Try} ("[1]#[0]" functor)] + ["[0]" exception {"+" Exception}] + ["[0]" io]] + [data + ["[0]" product] + [text + ["%" format {"+" format}]]] + [time + ["[0]" instant] + ["[0]" duration]]]] + [// + [meta + [archive {"+" Archive}]]]) (type: .public (Operation s o) (state.+State Try s o)) -(def: .public monad +(implementation: .public functor + (All (_ s) (Functor (Operation s))) + + (def: (each f it) + (function (_ state) + (case (it state) + {try.#Success [state' output]} + {try.#Success [state' (f output)]} + + {try.#Failure error} + {try.#Failure error})))) + +(implementation: .public monad (All (_ s) (Monad (Operation s))) - (state.with try.monad)) + + (def: &functor ..functor) + + (def: (in it) + (function (_ state) + {try.#Success [state it]})) + + (def: (conjoint it) + (function (_ state) + (case (it state) + {try.#Success [state' it']} + (it' state') + + {try.#Failure error} + {try.#Failure error})))) (type: .public (Phase s i o) (-> Archive i (Operation s o))) @@ -49,13 +72,13 @@ operation (# try.monad each product.right))) -(def: .public get_state +(def: .public state (All (_ s o) (Operation s s)) (function (_ state) {try.#Success [state state]})) -(def: .public (set_state state) +(def: .public (with state) (All (_ s o) (-> s (Operation s Any))) (function (_ _) @@ -77,19 +100,17 @@ (def: .public (except exception parameters) (All (_ e) (-> (Exception e) e Operation)) - (..failure (ex.error exception parameters))) + (..failure (exception.error exception parameters))) (def: .public (lifted error) (All (_ s a) (-> (Try a) (Operation s a))) (function (_ state) (try#each (|>> [state]) error))) -(syntax: .public (assertion [exception <code>.any - message <code>.any - test <code>.any]) - (in (list (` (if (~ test) - (# ..monad (~' in) []) - (..except (~ exception) (~ message))))))) +(template: .public (assertion exception message test) + [(if test + (# ..monad in []) + (..except exception message))]) (def: .public identity (All (_ s a) (Phase s a a)) @@ -106,19 +127,3 @@ [[pre/state' temp] (pre archive input pre/state) [post/state' output] (post archive temp post/state)] (in [[pre/state' post/state'] output])))) - -(def: .public (timed definition description operation) - (All (_ s a) - (-> Symbol Text (Operation s a) (Operation s a))) - (do ..monad - [_ (in []) - .let [pre (io.run! instant.now)] - output operation - .let [_ (|> instant.now - io.run! - instant.relative - (duration.difference (instant.relative pre)) - %.duration - (format (%.symbol definition) " [" description "]: ") - debug.log!)]] - (in output))) diff --git a/stdlib/source/library/lux/tool/interpreter.lux b/stdlib/source/library/lux/tool/interpreter.lux index abd53a54b..8cf01011c 100644 --- a/stdlib/source/library/lux/tool/interpreter.lux +++ b/stdlib/source/library/lux/tool/interpreter.lux @@ -101,7 +101,7 @@ (All (_ anchor expression directive) (-> Code <Interpretation>)) (do [! phase.monad] - [state (extension.lifted phase.get_state) + [state (extension.lifted phase.state) .let [analyse (value@ [directive.#analysis directive.#phase] state) synthesize (value@ [directive.#synthesis directive.#phase] state) generate (value@ [directive.#generation directive.#phase] state)] @@ -155,7 +155,7 @@ (-> Configuration Code (Operation anchor expression directive Text))) (do phase.monad [[codeT codeV] (interpret configuration code) - state phase.get_state] + state phase.state] (in (/type.represent (value@ [extension.#state directive.#analysis directive.#state extension.#state] diff --git a/stdlib/source/test/lux/control/state.lux b/stdlib/source/test/lux/control/state.lux index fb5ac42a2..40498c0d8 100644 --- a/stdlib/source/test/lux/control/state.lux +++ b/stdlib/source/test/lux/control/state.lux @@ -68,8 +68,7 @@ (def: structures Test (do random.monad - [state random.nat - value random.nat] + [state random.nat] ($_ _.and (_.for [/.functor] ($functor.spec ..injection (..comparison state) /.functor)) diff --git a/stdlib/source/test/lux/target/ruby.lux b/stdlib/source/test/lux/target/ruby.lux index 61fb1197e..d48e16ecb 100644 --- a/stdlib/source/test/lux/target/ruby.lux +++ b/stdlib/source/test/lux/target/ruby.lux @@ -223,34 +223,25 @@ (/.= /.nil))))) ))) -... (def: test|object -... Test -... (do [! random.monad] -... [expected random.safe_frac -... field (random.ascii/upper 5) -... dummy (random.only (|>> (text#= field) not) -... (random.ascii/upper 5)) - -... size (# ! each (|>> (n.% 10) ++) random.nat) -... index (# ! each (n.% size) random.nat) -... items (random.list size random.safe_frac)] -... ($_ _.and -... (_.cover [/.object /.the] -... (expression (|>> (:as Frac) (f.= expected)) -... (/.the field (/.object (list [field (/.float expected)]))))) -... (let [expected (|> items -... (list.item index) -... (maybe.else f.not_a_number))] -... (_.cover [/.do] -... (expression (|>> (:as Frac) f.int (i.= (.int index))) -... (|> (/.array (list#each /.float items)) -... (/.do "lastIndexOf" (list (/.float expected))))))) -... (_.cover [/.undefined] -... (expression (|>> (:as Bit)) -... (|> (/.object (list [field (/.float expected)])) -... (/.the dummy) -... (/.= /.undefined)))) -... ))) +(def: test|object + Test + (do [! random.monad] + [size (# ! each (|>> (n.% 10) ++) random.nat) + index (# ! each (n.% size) random.nat) + items (random.list size random.safe_frac)] + ($_ _.and + (_.cover [/.the] + (expression (|>> (:as Int) (i.= (.int size))) + (|> (/.array (list#each /.float items)) + (/.the "length")))) + (_.cover [/.do] + (expression (let [expected (|> items + (list.item index) + (maybe.else f.not_a_number))] + (|>> (:as Frac) (f.= expected))) + (|> (/.array (list#each /.float items)) + (/.do "at" (list (/.int (.int index))) {.#None})))) + ))) (def: test|computation Test @@ -270,7 +261,7 @@ ..test|int ..test|array ..test|hash - ... ..test|object + ..test|object (_.cover [/.?] (let [expected (if test then else)] (expression (|>> (:as Frac) (f.= expected)) @@ -539,25 +530,9 @@ (|> ($_ /.then (/.function $self (list $arg/0) (/.return (/.? (/.< (/.int (.int iterations)) $arg/0) - (/.apply/1 $self (/.+ (/.int +1) $arg/0)) + (/.apply/* (list (/.+ (/.int +1) $arg/0)) {.#None} $self) $arg/0))) - (/.return (/.apply/1 $self (/.int +0)))) - [(list)] (/.lambda {.#None}) - (/.apply_lambda/* (list))))) - (_.cover [/.apply/1] - (expression (|>> (:as Frac) (f.= float/0)) - (|> ($_ /.then - (/.function $self (list $arg/0) - (/.return $arg/0)) - (/.return (/.apply/1 $self (/.float float/0)))) - [(list)] (/.lambda {.#None}) - (/.apply_lambda/* (list))))) - (_.cover [/.apply/2] - (expression (|>> (:as Frac) (f.= ($_ f.+ float/0 float/1))) - (|> ($_ /.then - (/.function $self (list $arg/0 $arg/1) - (/.return ($_ /.+ $arg/0 $arg/1))) - (/.return (/.apply/2 $self (/.float float/0) (/.float float/1)))) + (/.return (/.apply/* (list (/.int +0)) {.#None} $self))) [(list)] (/.lambda {.#None}) (/.apply_lambda/* (list))))) (_.cover [/.apply/*] @@ -568,15 +543,6 @@ (/.return (/.apply/* (list (/.float float/0) (/.float float/1) (/.float float/2)) {.#None} $self))) [(list)] (/.lambda {.#None}) (/.apply_lambda/* (list))))) - ... (_.cover [/.new] - ... (let [$this (/.local "this")] - ... (expression (|>> (:as Frac) (f.= float/0)) - ... (/.apply/1 (/.closure (list $arg/0) - ... ($_ /.then - ... (/.function $class (list) - ... (/.set (/.the field $this) $arg/0)) - ... (/.return (/.the field (/.new $class (list)))))) - ... (/.float float/0))))) ))) (def: test|branching @@ -621,7 +587,9 @@ float/2 random.safe_frac $arg/0 (# ! each /.local (random.ascii/lower 10)) $arg/1 (# ! each /.local (random.ascii/lower 11)) - $arg/2 (# ! each /.local (random.ascii/lower 12))] + $arg/2 (# ! each /.local (random.ascii/lower 12)) + expected (# ! each (|>> %.int (text.replaced "+" "")) + random.int)] ($_ _.and (_.cover [/.statement] (expression (|>> (:as Frac) (f.= float/0)) @@ -637,6 +605,15 @@ (/.return $arg/1)) [(list $arg/0 $arg/1)] (/.lambda {.#None}) (/.apply_lambda/* (list (/.float float/0) (/.float float/1)))))) + (_.cover [/.require/1] + (let [$JSON (/.local "JSON")] + (expression (|>> (:as Text) (text#= expected)) + (|> ($_ /.then + (/.statement (/.require/1 (/.string "json"))) + (/.return (let [json (/.do "parse" (list $arg/0) {.#None} $JSON)] + (/.do "generate" (list json) {.#None} $JSON)))) + [(list $arg/0)] (/.lambda {.#None}) + (/.apply_lambda/* (list (/.string expected))))))) ..test|exception ..test|branching ..test|loop @@ -668,6 +645,9 @@ {.#None} true {.#Some _} false))) (try.else false))) + (_.cover [/.process_id] + (expression (|>> (:as Nat) (n.= 0) not) + /.process_id)) )) (def: random_expression diff --git a/stdlib/source/test/lux/tool.lux b/stdlib/source/test/lux/tool.lux index c60d3ba2d..79d25b75e 100644 --- a/stdlib/source/test/lux/tool.lux +++ b/stdlib/source/test/lux/tool.lux @@ -7,6 +7,7 @@ ["[1][0]" arity] ["[1][0]" version] ["[1][0]" reference] + ["[1][0]" phase] [language [lux ... ["[1][0]" syntax] @@ -30,6 +31,7 @@ /arity.test /version.test /reference.test + /phase.test /analysis/primitive.test /analysis/composite.test /analysis/pattern.test diff --git a/stdlib/source/test/lux/tool/compiler/phase.lux b/stdlib/source/test/lux/tool/compiler/phase.lux new file mode 100644 index 000000000..f0137730a --- /dev/null +++ b/stdlib/source/test/lux/tool/compiler/phase.lux @@ -0,0 +1,206 @@ +(.using + [library + [lux "*" + ["_" test {"+" Test}] + [abstract + [monad {"+" do}] + [\\specification + ["$[0]" functor {"+" Injection Comparison}] + ["$[0]" monad]]] + [control + [pipe {"+" case>}] + ["[0]" try ("[1]#[0]" functor)] + ["[0]" exception {"+" exception:}]] + [data + ["[0]" text ("[1]#[0]" equivalence) + ["%" format {"+" format}]]] + [math + ["[0]" random] + [number + ["n" nat] + ["i" int]]]]] + [\\library + ["[0]" / + [// + [meta + ["[0]" archive]]]]]) + +(def: (injection value) + (All (_ s) (Injection (/.Operation s))) + (function (_ state) + {try.#Success [state value]})) + +(def: (comparison init) + (All (_ s) (-> s (Comparison (/.Operation s)))) + (function (_ == left right) + (case [(/.result init left) + (/.result init right)] + [{try.#Success left} + {try.#Success right}] + (== left right) + + _ + false))) + +(exception: oops) + +(def: test|error + Test + (do [! random.monad] + [state random.nat + expected random.int + expected_error (random.ascii/lower 1)] + ($_ _.and + (_.cover [/.failure] + (|> (/.failure expected_error) + (/.result state) + (case> {try.#Failure actual_error} + (same? expected_error actual_error) + + _ + false))) + (_.cover [/.lifted] + (and (|> (/.lifted {try.#Failure expected_error}) + (/.result state) + (case> {try.#Failure actual_error} + (same? expected_error actual_error) + + _ + false)) + (|> (/.lifted {try.#Success expected}) + (# /.functor each (same? expected)) + (/.result state) + (try.else false)))) + (_.cover [/.except] + (|> (/.except ..oops []) + (/.result state) + (case> {try.#Failure error} + (exception.match? ..oops error) + + _ + false))) + (_.cover [/.assertion] + (and (|> (/.assertion ..oops [] false) + (/.result state) + (case> {try.#Failure error} + (exception.match? ..oops error) + + _ + false)) + (|> (/.assertion ..oops [] true) + (/.result state) + (case> {try.#Success _} + true + + _ + false)))) + ))) + +(def: test|state + Test + (do [! random.monad] + [state random.nat + dummy random.nat + expected random.int] + ($_ _.and + (_.cover [/.state] + (|> /.state + (# /.functor each (same? state)) + (/.result state) + (try.else false))) + (_.cover [/.with] + (|> (do /.monad + [_ (/.with state)] + /.state) + (# /.functor each (same? state)) + (/.result dummy) + (try.else false))) + (_.cover [/.sub] + (|> (/.sub [(# n.hex encoded) + (function (_ new old) + (|> new (# n.hex decoded) (try.else dummy)))] + (do /.monad + [state/hex /.state] + (in (|> state + (# n.hex encoded) + (text#= state/hex))))) + (/.result' state) + (case> {try.#Success [state' verdict]} + (and verdict + (n.= state state')) + + _ + false))) + ))) + +(def: test|operation + Test + (do [! random.monad] + [state random.nat + expected random.int] + ($_ _.and + (_.for [/.functor] + ($functor.spec ..injection (..comparison state) /.functor)) + (_.for [/.monad] + ($monad.spec ..injection (..comparison state) /.monad)) + + (_.cover [/.result] + (|> (# /.monad in expected) + (/.result state) + (case> {try.#Success actual} + (same? expected actual) + + _ + false))) + (_.cover [/.result'] + (|> (# /.monad in expected) + (/.result' state) + (case> {try.#Success [state' actual]} + (and (same? state state') + (same? expected actual)) + + _ + false))) + ..test|state + ..test|error + ))) + +(def: test|phase + Test + (do [! random.monad] + [state/0 random.nat + state/1 random.rev + expected random.int] + ($_ _.and + (_.cover [/.identity] + (|> (/.identity archive.empty expected) + (/.result state/0) + (try#each (same? expected)) + (try.else false))) + (_.cover [/.composite] + (let [phase (/.composite (: (/.Phase Nat Int Frac) + (function (_ archive input) + (# /.monad in (i.frac input)))) + (: (/.Phase Rev Frac Text) + (function (_ archive input) + (# /.monad in (%.frac input)))))] + (|> (phase archive.empty expected) + (/.result' [state/0 state/1]) + (case> {try.#Success [[state/0' state/1'] actual]} + (and (text#= (%.frac (i.frac expected)) actual) + (same? state/0 state/0') + (same? state/1 state/1')) + + _ + false)))) + ))) + +(def: .public test + Test + (<| (_.covering /._) + ($_ _.and + (_.for [/.Operation] + ..test|operation) + (_.for [/.Phase] + ..test|phase) + ))) |