diff options
Diffstat (limited to '')
4 files changed, 501 insertions, 1 deletions
diff --git a/stdlib/source/test/lux/control.lux b/stdlib/source/test/lux/control.lux index 80a94be6f..c0c673009 100644 --- a/stdlib/source/test/lux/control.lux +++ b/stdlib/source/test/lux/control.lux @@ -25,6 +25,7 @@ ["#/." cli] ["#/." code] ["#/." json] + ["#/." synthesis] ["#/." text]] ["#." pipe] ["#." reader] @@ -66,6 +67,7 @@ /parser/cli.test /parser/code.test /parser/json.test + /parser/synthesis.test /parser/text.test )) diff --git a/stdlib/source/test/lux/control/parser/synthesis.lux b/stdlib/source/test/lux/control/parser/synthesis.lux new file mode 100644 index 000000000..5dbf6a383 --- /dev/null +++ b/stdlib/source/test/lux/control/parser/synthesis.lux @@ -0,0 +1,161 @@ +(.module: + [lux #* + ["_" test (#+ Test)] + [abstract + ["." monad (#+ do)]] + [math + ["." random (#+ Random)]] + [control + [pipe (#+ case>)] + ["." try] + ["." exception] + ["<>" parser]] + [data + ["." bit] + ["." name] + ["." text] + [number + ["." i64] + ["n" nat] + ["." frac]] + [collection + ["." list ("#@." functor)]]] + [tool + [compiler + [reference (#+) + ["." variable (#+ Variable)]] + [language + [lux + [analysis (#+ Environment)] + ["." synthesis]]]]]] + {1 + ["." /]}) + +(template: (!expect <pattern> <value>) + (case <value> + <pattern> + true + + _ + false)) + +(def: random-constant + (Random Name) + (random.and (random.unicode 1) + (random.unicode 1))) + +(def: random-variable + (Random Variable) + (random.or random.nat + random.nat)) + +(def: random-environment + (Random Environment) + (do {@ random.monad} + [size (:: @ map (n.% 5) random.nat)] + (random.list size ..random-variable))) + +(def: #export test + Test + (<| (_.covering /._) + (_.with-cover [/.Parser]) + ($_ _.and + (do {@ random.monad} + [expected (:: @ map (|>> synthesis.i64) random.nat)] + (_.cover [/.run /.any] + (|> (/.run /.any (list expected)) + (!expect (^multi (#try.Success actual) + (:: synthesis.equivalence = expected actual)))))) + (_.cover [/.empty-input] + (|> (/.run /.any (list)) + (!expect (^multi (#try.Failure error) + (exception.match? /.empty-input error))))) + (do {@ random.monad} + [expected (:: @ map (|>> synthesis.i64) random.nat)] + (_.cover [/.unconsumed-input] + (|> (/.run /.any (list expected expected)) + (!expect (^multi (#try.Failure error) + (exception.match? /.unconsumed-input error)))))) + (do {@ random.monad} + [dummy (:: @ map (|>> synthesis.i64) random.nat)] + (_.cover [/.end! /.expected-empty-input] + (and (|> (/.run /.end! (list)) + (!expect (#try.Success _))) + (|> (/.run /.end! (list dummy)) + (!expect (^multi (#try.Failure error) + (exception.match? /.expected-empty-input error))))))) + (do {@ random.monad} + [dummy (:: @ map (|>> synthesis.i64) random.nat)] + (_.cover [/.end?] + (and (|> (/.run /.end? (list)) + (!expect (#try.Success #1))) + (|> (/.run (<>.before /.any /.end?) (list dummy)) + (!expect (#try.Success #0)))))) + (_.with-cover [/.cannot-parse] + (`` ($_ _.and + (~~ (template [<query> <check> <random> <synthesis> <equivalence>] + [(do {@ random.monad} + [expected <random> + dummy (|> <random> (random.filter (|>> (:: <equivalence> = expected) not)))] + ($_ _.and + (_.cover [<query>] + (|> (/.run <query> (list (<synthesis> expected))) + (!expect (^multi (#try.Success actual) + (:: <equivalence> = expected actual))))) + (_.cover [<check>] + (and (|> (/.run (<check> expected) (list (<synthesis> expected))) + (!expect (#try.Success _))) + (|> (/.run (<check> expected) (list (<synthesis> dummy))) + (!expect (^multi (#try.Failure error) + (exception.match? /.cannot-parse error))))))))] + + [/.bit /.bit! random.bit synthesis.bit bit.equivalence] + [/.i64 /.i64! (:: @ map .i64 random.nat) synthesis.i64 i64.equivalence] + [/.f64 /.f64! random.frac synthesis.f64 frac.equivalence] + [/.text /.text! (random.unicode 1) synthesis.text text.equivalence] + [/.local /.local! random.nat synthesis.variable/local n.equivalence] + [/.foreign /.foreign! random.nat synthesis.variable/foreign n.equivalence] + [/.constant /.constant! ..random-constant synthesis.constant name.equivalence] + )) + (do {@ random.monad} + [expected-bit random.bit + expected-i64 (:: @ map .i64 random.nat) + expected-f64 random.frac + expected-text (random.unicode 1)] + (_.cover [/.tuple] + (and (|> (/.run (/.tuple ($_ <>.and /.bit /.i64 /.f64 /.text)) + (list (synthesis.tuple (list (synthesis.bit expected-bit) + (synthesis.i64 expected-i64) + (synthesis.f64 expected-f64) + (synthesis.text expected-text))))) + (!expect (^multi (#try.Success [actual-bit actual-i64 actual-f64 actual-text]) + (and (:: bit.equivalence = expected-bit actual-bit) + (:: i64.equivalence = expected-i64 actual-i64) + (:: frac.equivalence = expected-f64 actual-f64) + (:: text.equivalence = expected-text actual-text))))) + (|> (/.run (/.tuple ($_ <>.and /.bit /.i64 /.f64 /.text)) + (list (synthesis.text expected-text))) + (!expect (^multi (#try.Failure error) + (exception.match? /.cannot-parse error))))))) + (do {@ random.monad} + [arity random.nat + expected-environment ..random-environment + expected-body (random.unicode 1)] + (_.cover [/.function /.wrong-arity] + (and (|> (/.run (/.function arity /.text) + (list (synthesis.function/abstraction [expected-environment arity (synthesis.text expected-body)]))) + (!expect (^multi (#try.Success [actual-environment actual-body]) + (and (:: (list.equivalence variable.equivalence) = + expected-environment + actual-environment) + (:: text.equivalence = expected-body actual-body))))) + (|> (/.run (/.function arity /.text) + (list (synthesis.text expected-body))) + (!expect (^multi (#try.Failure error) + (exception.match? /.cannot-parse error)))) + (|> (/.run (/.function (inc arity) /.text) + (list (synthesis.function/abstraction [expected-environment arity (synthesis.text expected-body)]))) + (!expect (^multi (#try.Failure error) + (exception.match? /.wrong-arity error))))))) + ))) + ))) diff --git a/stdlib/source/test/lux/tool/compiler/language/lux/phase/synthesis.lux b/stdlib/source/test/lux/tool/compiler/language/lux/phase/synthesis.lux index 46291b311..4a7a7c507 100644 --- a/stdlib/source/test/lux/tool/compiler/language/lux/phase/synthesis.lux +++ b/stdlib/source/test/lux/tool/compiler/language/lux/phase/synthesis.lux @@ -6,7 +6,8 @@ ["#." structure] ["#." case] ["#." function] - ["#." loop]]) + ["#." loop] + ["#." variable]]) (def: #export test Test @@ -16,4 +17,5 @@ /case.test /function.test /loop.test + /variable.test )) diff --git a/stdlib/source/test/lux/tool/compiler/language/lux/phase/synthesis/variable.lux b/stdlib/source/test/lux/tool/compiler/language/lux/phase/synthesis/variable.lux new file mode 100644 index 000000000..b90829862 --- /dev/null +++ b/stdlib/source/test/lux/tool/compiler/language/lux/phase/synthesis/variable.lux @@ -0,0 +1,335 @@ +(.module: + [lux #* + ["_" test (#+ Test)] + [abstract + ["." monad (#+ do)]] + [math + ["." random (#+ Random)]] + [control + [pipe (#+ case>)] + ["." try]] + [data + ["." product] + ["." text + ["%" format (#+ format)]] + [number + ["n" nat]] + [collection + ["." list ("#@." functor fold)] + ["." dictionary (#+ Dictionary)]]]] + {1 + ["." / + [//// + ["." analysis] + ["." synthesis (#+ Side Member Path Synthesis)] + [/// + [reference (#+) + ["." variable]]]]]}) + +(template: (!expect <pattern> <value>) + (case <value> + <pattern> + true + + _ + false)) + +(type: Context + {#redundants Nat + #necessary (Dictionary Nat Nat)}) + +(type: (Scenario a) + (-> Context (Random [a a]))) + +(template [<name> <synthesis> <random>] + [(def: (<name> context) + (Scenario Synthesis) + (do {@ random.monad} + [value <random>] + (wrap [(<synthesis> value) + (<synthesis> value)])))] + + [bit-scenario synthesis.bit random.bit] + [i64-scenario synthesis.i64 (:: @ map .i64 random.nat)] + [f64-scenario synthesis.f64 random.frac] + [text-scenario synthesis.text (random.unicode 1)] + ) + +(def: (primitive-scenario context) + (Scenario Synthesis) + (random.either (random.either (..bit-scenario context) + (..i64-scenario context)) + (random.either (..f64-scenario context) + (..text-scenario context)))) + +(def: (with-redundancy scenario context) + (-> (Scenario Synthesis) (Scenario Synthesis)) + (do {@ random.monad} + [redundant? random.bit] + (if redundant? + (do @ + [let? random.bit + [expected-input actual-input] (..primitive-scenario context) + #let [fake-register (n.+ (get@ #redundants context) + (dictionary.size (get@ #necessary context)))] + [expected-output actual-output] (scenario (update@ #redundants inc context))] + (wrap [(synthesis.branch/case [expected-input + (#synthesis.Seq #synthesis.Pop + (#synthesis.Then expected-output))]) + (if let? + (synthesis.branch/let [actual-input fake-register actual-output]) + (synthesis.branch/case [actual-input + (#synthesis.Seq (#synthesis.Bind fake-register) + (#synthesis.Seq #synthesis.Pop + (#synthesis.Then actual-output)))]))])) + (scenario context)))) + +(def: (variant-scenario scenario context) + (-> (Scenario Synthesis) (Scenario Synthesis)) + (do {@ random.monad} + [lefts random.nat + right? random.bit + [expected input] (scenario context)] + (wrap [(synthesis.variant [lefts right? expected]) + (synthesis.variant [lefts right? input])]))) + +(def: (tuple-scenario context) + (Scenario Synthesis) + (let [registers (dictionary.entries (get@ #necessary context))] + (:: random.monad wrap + [(synthesis.tuple (list@map (|>> product.left synthesis.variable/local) registers)) + (synthesis.tuple (list@map (|>> product.right synthesis.variable/local) registers))]))) + +(def: (structure-scenario context) + (Scenario Synthesis) + (random.either (..variant-scenario (..with-redundancy ..tuple-scenario) context) + (..tuple-scenario context))) + +(def: (let-scenario scenario context) + (-> (Scenario Synthesis) (Scenario Synthesis)) + (do random.monad + [_ (wrap []) + [expected-input actual-input] (scenario context) + #let [real-register (dictionary.size (get@ #necessary context)) + fake-register (n.+ (get@ #redundants context) + (dictionary.size (get@ #necessary context)))] + [expected-output actual-output] (scenario (update@ #necessary (dictionary.put real-register fake-register) context))] + (wrap [(synthesis.branch/let [expected-input real-register expected-output]) + (synthesis.branch/let [actual-input fake-register actual-output])]))) + +(def: (if-scenario scenario context) + (-> (Scenario Synthesis) (Scenario Synthesis)) + (do random.monad + [_ (wrap []) + [expected-test actual-test] (scenario context) + [expected-then actual-then] (scenario context) + [expected-else actual-else] (scenario context)] + (wrap [(synthesis.branch/if [expected-test + expected-then + expected-else]) + (synthesis.branch/if [actual-test + actual-then + actual-else])]))) + +(def: random-member + (Random Member) + (do random.monad + [lefts random.nat + right? random.bit] + (wrap (if right? + (#.Right lefts) + (#.Left lefts))))) + +(def: (get-scenario scenario context) + (-> (Scenario Synthesis) (Scenario Synthesis)) + (do {@ random.monad} + [length (:: @ map (|>> (n.% 5) inc) random.nat) + path (random.list length ..random-member) + [expected-record actual-record] (scenario context)] + (wrap [(synthesis.branch/get [path expected-record]) + (synthesis.branch/get [path actual-record])]))) + +(def: random-side + (Random Side) + ..random-member) + +(def: (path-scenario scenario context) + (-> (Scenario Synthesis) (Scenario Path)) + (`` ($_ random.either + ($_ random.either + (do {@ random.monad} + [_ (wrap []) + [expected-then actual-then] (scenario context)] + (wrap [(#synthesis.Seq #synthesis.Pop + (#synthesis.Then expected-then)) + (#synthesis.Seq #synthesis.Pop + (#synthesis.Then actual-then))])) + (do {@ random.monad} + [_ (wrap []) + #let [real-register (dictionary.size (get@ #necessary context)) + fake-register (n.+ (get@ #redundants context) + (dictionary.size (get@ #necessary context)))] + [expected-then actual-then] (scenario (update@ #necessary (dictionary.put real-register fake-register) context))] + (wrap [(#synthesis.Seq (#synthesis.Bind real-register) + (#synthesis.Seq #synthesis.Pop + (#synthesis.Then expected-then))) + (#synthesis.Seq (#synthesis.Bind fake-register) + (#synthesis.Seq #synthesis.Pop + (#synthesis.Then actual-then)))]))) + ($_ random.either + (~~ (template [<tag> <random>] + [(do {@ random.monad} + [test <random> + [expected-then actual-then] (scenario context)] + (wrap [(#synthesis.Seq (#synthesis.Test (<tag> test)) + (#synthesis.Then expected-then)) + (#synthesis.Seq (#synthesis.Test (<tag> test)) + (#synthesis.Then actual-then))]))] + + [#synthesis.Bit random.bit] + [#synthesis.I64 (:: @ map .i64 random.nat)] + [#synthesis.F64 random.frac] + [#synthesis.Text (random.unicode 1)] + ))) + ($_ random.either + (do {@ random.monad} + [side ..random-side + [expected-next actual-next] (path-scenario scenario context)] + (wrap [(#synthesis.Seq (#synthesis.Access (#synthesis.Side side)) + expected-next) + (#synthesis.Seq (#synthesis.Access (#synthesis.Side side)) + actual-next)])) + (do {@ random.monad} + [member ..random-member + [expected-next actual-next] (path-scenario scenario context)] + (wrap [(#synthesis.Seq (#synthesis.Access (#synthesis.Member member)) + expected-next) + (#synthesis.Seq (#synthesis.Access (#synthesis.Member member)) + actual-next)]))) + (do {@ random.monad} + [_ (wrap []) + [expected-left actual-left] (path-scenario scenario context) + [expected-right actual-right] (path-scenario scenario context)] + (wrap [(#synthesis.Alt expected-left expected-right) + (#synthesis.Alt actual-left actual-right)])) + ))) + +(def: (case-scenario scenario context) + (-> (Scenario Synthesis) (Scenario Synthesis)) + (do {@ random.monad} + [_ (wrap []) + [expected-input actual-input] (scenario context) + [expected-path actual-path] (..path-scenario scenario context)] + (wrap [(synthesis.branch/case [expected-input expected-path]) + (synthesis.branch/case [actual-input actual-path])]))) + +(def: (branch-scenario scenario context) + (-> (Scenario Synthesis) (Scenario Synthesis)) + ($_ random.either + (..let-scenario scenario context) + (..if-scenario scenario context) + (..get-scenario scenario context) + (..case-scenario scenario context) + )) + +(def: scope-arity 5) + +(def: (scope-scenario scenario context) + (-> (Scenario Synthesis) (Scenario Synthesis)) + (do {@ random.monad} + [_ (wrap []) + #let [real-start (dictionary.size (get@ #necessary context)) + fake-start (n.+ (get@ #redundants context) + real-start)] + inits (random.list ..scope-arity (scenario context)) + [expected-iteration actual-iteration] (scenario (update@ #necessary + (function (_ necessary) + (list@fold (function (_ [idx _] context) + (dictionary.put (n.+ real-start idx) + (n.+ fake-start idx) + context)) + necessary + (list.enumerate inits))) + context))] + (wrap [(synthesis.loop/scope [real-start (list@map product.left inits) expected-iteration]) + (synthesis.loop/scope [fake-start (list@map product.right inits) actual-iteration])]))) + +(def: (recur-scenario scenario context) + (-> (Scenario Synthesis) (Scenario Synthesis)) + (do {@ random.monad} + [_ (wrap []) + resets (random.list ..scope-arity (scenario context))] + (wrap [(synthesis.loop/recur (list@map product.left resets)) + (synthesis.loop/recur (list@map product.right resets))]))) + +(def: (loop-scenario scenario context) + (-> (Scenario Synthesis) (Scenario Synthesis)) + ($_ random.either + (..scope-scenario scenario context) + (..recur-scenario scenario context) + )) + +(def: (abstraction-scenario scenario context) + (-> (Scenario Synthesis) (Scenario Synthesis)) + (do {@ random.monad} + [_ (wrap []) + #let [registers (dictionary.entries (get@ #necessary context)) + expected-environment (list@map (|>> product.left #variable.Local) registers) + actual-environment (list@map (|>> product.right #variable.Local) registers)] + [expected-body actual-body] (..primitive-scenario context)] + (wrap [(synthesis.function/abstraction [expected-environment 1 expected-body]) + (synthesis.function/abstraction [actual-environment 1 actual-body])]))) + +(def: (apply-scenario scenario context) + (-> (Scenario Synthesis) (Scenario Synthesis)) + (do {@ random.monad} + [abstraction (:: @ map (|>> synthesis.constant) + (random.and (random.unicode 1) + (random.unicode 1))) + inputs (random.list ..scope-arity (scenario context))] + (wrap [(synthesis.function/apply [abstraction (list@map product.left inputs)]) + (synthesis.function/apply [abstraction (list@map product.right inputs)])]))) + +(def: (function-scenario scenario context) + (-> (Scenario Synthesis) (Scenario Synthesis)) + ($_ random.either + (..abstraction-scenario scenario context) + (..apply-scenario scenario context) + )) + +(def: (control-scenario scenario context) + (-> (Scenario Synthesis) (Scenario Synthesis)) + ($_ random.either + (..branch-scenario scenario context) + (..loop-scenario scenario context) + (..function-scenario scenario context) + )) + +(def: (scenario context) + (Scenario Synthesis) + ($_ random.either + (..primitive-scenario context) + (..structure-scenario context) + (..control-scenario (..with-redundancy + (..control-scenario + (..with-redundancy + ..structure-scenario))) + context) + )) + +(def: default + Context + {#redundants 0 + #necessary (dictionary.new n.hash)}) + +(def: #export test + Test + (<| (_.covering /._) + ($_ _.and + (do random.monad + [[expected input] (..scenario ..default)] + (_.cover [/.optimization] + (|> (/.optimization input) + (!expect (^multi (#try.Success actual) + (:: synthesis.equivalence = expected actual)))))) + ))) |