diff options
Diffstat (limited to '')
7 files changed, 936 insertions, 22 deletions
diff --git a/stdlib/source/lux/control/parser/synthesis.lux b/stdlib/source/lux/control/parser/synthesis.lux index 5e3b1dadb..b4ad2184b 100644 --- a/stdlib/source/lux/control/parser/synthesis.lux +++ b/stdlib/source/lux/control/parser/synthesis.lux @@ -26,16 +26,10 @@ ["/" synthesis (#+ Synthesis Abstraction)]]]]]] ["." //]) -(def: (remaining-inputs asts) - (-> (List Synthesis) Text) - (format text.new-line "Remaining input: " - (|> asts - (list@map /.%synthesis) - (list.interpose " ") - (text.join-with "")))) - ## TODO: Use "type:" ASAP. -(def: Input Type (type (List Synthesis))) +(def: Input + Type + (type (List Synthesis))) (exception: #export (cannot-parse {input ..Input}) (exception.report @@ -45,6 +39,10 @@ (exception.report ["Input" (exception.enumerate /.%synthesis input)])) +(exception: #export (expected-empty-input {input ..Input}) + (exception.report + ["Input" (exception.enumerate /.%synthesis input)])) + (exception: #export (wrong-arity {expected Arity} {actual Arity}) (exception.report ["Expected" (%.nat expected)] @@ -83,8 +81,7 @@ (.function (_ tokens) (case tokens #.Nil (#try.Success [tokens []]) - _ (#try.Failure (format "Expected list of tokens to be empty!" - (remaining-inputs tokens)))))) + _ (exception.throw ..expected-empty-input [tokens])))) (def: #export end? {#.doc "Checks whether there are no more inputs."} diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/synthesis.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/synthesis.lux index 33e94f89a..54f299c31 100644 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/synthesis.lux +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/synthesis.lux @@ -13,6 +13,7 @@ ["." / #_ ["#." function] ["#." case] + ["#." variable] ["/#" // #_ ["#." extension] ["/#" // #_ @@ -42,9 +43,9 @@ [#///analysis.Int #/.I64] [#///analysis.Rev #/.I64]))) -(def: #export (phase archive) +(def: (optimization archive) Phase - (function (phase' analysis) + (function (optimization' analysis) (case analysis (#///analysis.Primitive analysis') (phase@wrap (#/.Primitive (..primitive analysis'))) @@ -54,12 +55,12 @@ (case structure (#///analysis.Variant variant) (do phase.monad - [valueS (phase' (get@ #///analysis.value variant))] + [valueS (optimization' (get@ #///analysis.value variant))] (wrap (/.variant (set@ #///analysis.value valueS variant)))) (#///analysis.Tuple tuple) (|> tuple - (monad.map phase.monad phase') + (monad.map phase.monad optimization') (phase@map (|>> /.tuple))))) (#///analysis.Reference reference) @@ -67,29 +68,35 @@ (#///analysis.Case inputA branchesAB+) (/.with-currying? false - (/case.synthesize phase branchesAB+ archive inputA)) + (/case.synthesize optimization branchesAB+ archive inputA)) (^ (///analysis.no-op value)) - (phase' value) + (optimization' value) (#///analysis.Apply _) (/.with-currying? false - (/function.apply phase archive analysis)) + (/function.apply optimization archive analysis)) (#///analysis.Function environmentA bodyA) - (/function.abstraction phase environmentA archive bodyA) + (/function.abstraction optimization environmentA archive bodyA) (#///analysis.Extension name args) (/.with-currying? false (function (_ state) - (|> (//extension.apply archive phase [name args]) + (|> (//extension.apply archive optimization [name args]) (phase.run' state) (case> (#try.Success output) (#try.Success output) (#try.Failure _) (|> args - (monad.map phase.monad phase') + (monad.map phase.monad optimization') (phase@map (|>> [name] #/.Extension)) (phase.run' state)))))) ))) + +(def: #export (phase archive analysis) + Phase + (do phase.monad + [synthesis (..optimization archive analysis)] + (phase.lift (/variable.optimization synthesis)))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/synthesis/variable.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/synthesis/variable.lux new file mode 100644 index 000000000..dd0d49608 --- /dev/null +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/synthesis/variable.lux @@ -0,0 +1,410 @@ +(.module: + [lux #* + [abstract + ["." monad (#+ do)]] + [control + ["." try (#+ Try)] + ["." exception (#+ exception:)]] + [data + ["." product] + ["." maybe] + [number + ["n" nat]] + ["." text + ["%" format]] + [collection + ["." dictionary (#+ Dictionary)] + ["." list ("#@." functor fold)] + ["." set]]]] + [//// + ["/" synthesis (#+ Path Synthesis)] + ["." analysis] + [/// + [arity (#+ Arity)] + ["." reference + ["." variable (#+ Register Variable)]]]]) + +(def: (prune redundant register) + (-> Register Register Register) + (if (n.> redundant register) + (dec register) + register)) + +(type: (Remover a) + (-> Register (-> a a))) + +(def: (remove-local-from-path remove-local redundant) + (-> (Remover Synthesis) (Remover Path)) + (function (recur path) + (case path + (#/.Seq (#/.Bind register) + post) + (if (n.= redundant register) + (recur post) + (#/.Seq (#/.Bind (if (n.> redundant register) + (dec register) + register)) + (recur post))) + + (^or (#/.Seq (#/.Access (#/.Member member)) + (#/.Seq (#/.Bind register) + post)) + ## This alternative form should never occur in practice. + ## Yet, it is "technically" possible to construct it. + (#/.Seq (#/.Seq (#/.Access (#/.Member member)) + (#/.Bind register)) + post)) + (if (n.= redundant register) + (recur post) + (#/.Seq (#/.Access (#/.Member member)) + (#/.Seq (#/.Bind (if (n.> redundant register) + (dec register) + register)) + (recur post)))) + + (^template [<tag>] + (<tag> left right) + (<tag> (recur left) (recur right))) + ([#/.Seq] + [#/.Alt]) + + (^or #/.Pop + (#/.Test _) + (#/.Access _)) + path + + (#/.Bind register) + (undefined) + + (#/.Then then) + (#/.Then (remove-local redundant then)) + ))) + +(def: (remove-local-from-variable redundant variable) + (Remover Variable) + (case variable + (#variable.Local register) + (#variable.Local (..prune redundant register)) + + (#variable.Foreign register) + variable)) + +(def: (remove-local redundant) + (Remover Synthesis) + (function (recur synthesis) + (case synthesis + (#/.Primitive _) + synthesis + + (#/.Structure structure) + (#/.Structure (case structure + (#analysis.Variant [lefts right value]) + (#analysis.Variant [lefts right (recur value)]) + + (#analysis.Tuple tuple) + (#analysis.Tuple (list@map recur tuple)))) + + (#/.Reference reference) + (case reference + (#reference.Variable variable) + (/.variable (..remove-local-from-variable redundant variable)) + + (#reference.Constant constant) + synthesis) + + (#/.Control control) + (#/.Control (case control + (#/.Branch branch) + (#/.Branch (case branch + (#/.Let input register output) + (#/.Let (recur input) + (..prune redundant register) + (recur output)) + + (#/.If test then else) + (#/.If (recur test) (recur then) (recur else)) + + (#/.Get path record) + (#/.Get path (recur record)) + + (#/.Case input path) + (#/.Case (recur input) (remove-local-from-path remove-local redundant path)))) + + (#/.Loop loop) + (#/.Loop (case loop + (#/.Scope [start inits iteration]) + (#/.Scope [(..prune redundant start) + (list@map recur inits) + (recur iteration)]) + + (#/.Recur resets) + (#/.Recur (list@map recur resets)))) + + (#/.Function function) + (#/.Function (case function + (#/.Abstraction [environment arity body]) + (#/.Abstraction [(list@map (..remove-local-from-variable redundant) environment) + arity + body]) + + (#/.Apply abstraction inputs) + (#/.Apply (recur abstraction) (list@map recur inputs)))))) + + (#/.Extension name inputs) + (#/.Extension name (list@map recur inputs))))) + +(type: Redundancy + (Dictionary Register Bit)) + +(def: initial + Redundancy + (dictionary.new n.hash)) + +(def: redundant! true) +(def: necessary! false) + +(def: (extended offset amount redundancy) + (-> Register Nat Redundancy [(List Register) Redundancy]) + (let [extension (|> amount list.indices (list@map (n.+ offset)))] + [extension + (list@fold (function (_ register redundancy) + (dictionary.put register ..necessary! redundancy)) + redundancy + extension)])) + +(def: (default arity) + (-> Arity Redundancy) + (product.right (..extended 0 (inc arity) ..initial))) + +(type: (Optimization a) + (-> [Redundancy a] (Try [Redundancy a]))) + +(def: (list-optimization optimization) + (-> (Optimization Synthesis) (Optimization (List Synthesis))) + (function (recur [redundancy values]) + (case values + #.Nil + (#try.Success [redundancy + values]) + + (#.Cons head tail) + (do try.monad + [[redundancy head] (optimization [redundancy head]) + [redundancy tail] (recur [redundancy tail])] + (wrap [redundancy + (#.Cons head tail)]))))) + +(template [<name>] + [(exception: #export (<name> {register Register}) + (exception.report + ["Register" (%.nat register)]))] + + [redundant-declaration] + [unknown-register] + ) + +(def: (declare register redundancy) + (-> Register Redundancy (Try Redundancy)) + (case (dictionary.get register redundancy) + #.None + (#try.Success (dictionary.put register ..redundant! redundancy)) + + (#.Some _) + (exception.throw ..redundant-declaration [register]))) + +(def: (observe register redundancy) + (-> Register Redundancy (Try Redundancy)) + (case (dictionary.get register redundancy) + #.None + (exception.throw ..unknown-register [register]) + + (#.Some _) + (#try.Success (dictionary.put register ..necessary! redundancy)))) + +(def: (format redundancy) + (%.Format Redundancy) + (|> redundancy + dictionary.entries + (list@map (function (_ [register redundant?]) + (%.format (%.nat register) ": " (%.bit redundant?)))) + (text.join-with ", "))) + +(def: (path-optimization optimization) + (-> (Optimization Synthesis) (Optimization Path)) + (function (recur [redundancy path]) + (case path + (^or #/.Pop + (#/.Test _) + (#/.Access _)) + (#try.Success [redundancy + path]) + + (#/.Bind register) + (do try.monad + [redundancy (..declare register redundancy)] + (wrap [redundancy + path])) + + (#/.Alt left right) + (do try.monad + [[redundancy left] (recur [redundancy left]) + [redundancy right] (recur [redundancy right])] + (wrap [redundancy (#/.Alt left right)])) + + (#/.Seq pre post) + (do try.monad + [#let [baseline (|> redundancy + dictionary.keys + (set.from-list n.hash))] + [redundancy pre] (recur [redundancy pre]) + #let [bindings (|> redundancy + dictionary.keys + (set.from-list n.hash) + (set.difference baseline))] + [redundancy post] (recur [redundancy post]) + #let [redundants (|> redundancy + dictionary.entries + (list.filter (function (_ [register redundant?]) + (and (set.member? bindings register) + redundant?))) + (list@map product.left))]] + (wrap [(list@fold dictionary.remove redundancy (set.to-list bindings)) + (|> redundants + (list.sort n.>) + (list@fold (..remove-local-from-path ..remove-local) (#/.Seq pre post)))])) + + (#/.Then then) + (do try.monad + [[redundancy then] (optimization [redundancy then])] + (wrap [redundancy (#/.Then then)])) + ))) + +(def: (variable-optimization variable redundancy) + (-> Variable Redundancy (Try Redundancy)) + (case variable + (#variable.Local register) + (..observe register redundancy) + + (#variable.Foreign register) + (#try.Success redundancy))) + +(def: (optimization' [redundancy synthesis]) + (Optimization Synthesis) + (with-expansions [<no-op> (as-is (#try.Success [redundancy + synthesis]))] + (case synthesis + (#/.Primitive _) + <no-op> + + (#/.Structure structure) + (case structure + (#analysis.Variant [lefts right value]) + (do try.monad + [[redundancy value] (optimization' [redundancy value])] + (wrap [redundancy + (#/.Structure (#analysis.Variant [lefts right value]))])) + + (#analysis.Tuple tuple) + (do try.monad + [[redundancy tuple] (..list-optimization optimization' [redundancy tuple])] + (wrap [redundancy + (#/.Structure (#analysis.Tuple tuple))]))) + + (#/.Reference reference) + (case reference + (#reference.Variable variable) + (case variable + (#variable.Local register) + (do try.monad + [redundancy (..observe register redundancy)] + <no-op>) + + (#variable.Foreign register) + <no-op>) + + (#reference.Constant constant) + <no-op>) + + (#/.Control control) + (case control + (#/.Branch branch) + (case branch + (#/.Let input register output) + (do try.monad + [[redundancy input] (optimization' [redundancy input]) + redundancy (..declare register redundancy) + [redundancy output] (optimization' [redundancy output]) + #let [redundant? (|> redundancy + (dictionary.get register) + (maybe.default ..necessary!))]] + (wrap [(dictionary.remove register redundancy) + (#/.Control (if redundant? + (#/.Branch (#/.Case input + (#/.Seq #/.Pop + (#/.Then (..remove-local register output))))) + (#/.Branch (#/.Let input register output))))])) + + (#/.If test then else) + (do try.monad + [[redundancy test] (optimization' [redundancy test]) + [redundancy then] (optimization' [redundancy then]) + [redundancy else] (optimization' [redundancy else])] + (wrap [redundancy + (#/.Control (#/.Branch (#/.If test then else)))])) + + (#/.Get path record) + (do try.monad + [[redundancy record] (optimization' [redundancy record])] + (wrap [redundancy + (#/.Control (#/.Branch (#/.Get path record)))])) + + (#/.Case input path) + (do try.monad + [[redundancy input] (optimization' [redundancy input]) + [redundancy path] (..path-optimization optimization' [redundancy path])] + (wrap [redundancy + (#/.Control (#/.Branch (#/.Case input path)))]))) + + (#/.Loop loop) + (case loop + (#/.Scope [start inits iteration]) + (do try.monad + [[redundancy inits] (..list-optimization optimization' [redundancy inits]) + #let [[extension redundancy] (..extended start (list.size inits) redundancy)] + [redundancy iteration] (optimization' [redundancy iteration])] + (wrap [(list@fold dictionary.remove redundancy extension) + (#/.Control (#/.Loop (#/.Scope [start inits iteration])))])) + + (#/.Recur resets) + (do try.monad + [[redundancy resets] (..list-optimization optimization' [redundancy resets])] + (wrap [redundancy + (#/.Control (#/.Loop (#/.Recur resets)))]))) + + (#/.Function function) + (case function + (#/.Abstraction [environment arity body]) + (do {@ try.monad} + [redundancy (monad.fold @ ..variable-optimization redundancy environment) + [_ body] (optimization' [(..default arity) body])] + (wrap [redundancy + (#/.Control (#/.Function (#/.Abstraction [environment arity body])))])) + + (#/.Apply abstraction inputs) + (do try.monad + [[redundancy abstraction] (optimization' [redundancy abstraction]) + [redundancy inputs] (..list-optimization optimization' [redundancy inputs])] + (wrap [redundancy + (#/.Control (#/.Function (#/.Apply abstraction inputs)))])))) + + (#/.Extension name inputs) + (do try.monad + [[redundancy inputs] (..list-optimization optimization' [redundancy inputs])] + (wrap [redundancy + (#/.Extension name inputs)]))))) + +(def: #export optimization + (-> Synthesis (Try Synthesis)) + (|>> [..initial] + optimization' + (:: try.monad map product.right))) 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)))))) + ))) |