diff options
Diffstat (limited to '')
12 files changed, 696 insertions, 232 deletions
diff --git a/stdlib/source/lux.lux b/stdlib/source/lux.lux index bda5f60d9..e76d59d1a 100644 --- a/stdlib/source/lux.lux +++ b/stdlib/source/lux.lux @@ -1814,7 +1814,7 @@ (return (wrap-meta (form$ (list (tag$ ["lux" "Frac"]) (frac$ value))))) [_ [_ (#Text value)]] - (return (wrap-meta (form$ (list (tag$ ["lux" "Text"]) (text$ value))))) + (return (untemplate-text value)) [#0 [_ (#Tag [module name])]] (return (wrap-meta (form$ (list (tag$ ["lux" "Tag"]) (tuple$ (list (text$ module) (text$ name))))))) diff --git a/stdlib/source/lux/control/parser/json.lux b/stdlib/source/lux/control/parser/json.lux index ed1620627..48006855b 100644 --- a/stdlib/source/lux/control/parser/json.lux +++ b/stdlib/source/lux/control/parser/json.lux @@ -30,8 +30,8 @@ (exception: #export empty-input) -(def: #export (run json parser) - (All [a] (-> JSON (Parser a) (Try a))) +(def: #export (run parser json) + (All [a] (-> (Parser a) JSON (Try a))) (case (//.run parser (list json)) (#try.Success [remainder output]) (case remainder @@ -39,93 +39,97 @@ (#try.Success output) _ - (exception.throw unconsumed-input remainder)) + (exception.throw ..unconsumed-input remainder)) (#try.Failure error) (#try.Failure error))) -(def: #export (fail error) - (All [a] (-> Text (Parser a))) - (function (_ inputs) - (#try.Failure error))) - (def: #export any {#.doc "Just returns the JSON input without applying any logic."} (Parser JSON) (<| (function (_ inputs)) (case inputs #.Nil - (exception.throw empty-input []) + (exception.throw ..empty-input []) (#.Cons head tail) (#try.Success [tail head])))) +(exception: #export (unexpected-value {value JSON}) + (exception.report + ["Value" (/.format value)])) + (template [<name> <type> <tag> <desc>] [(def: #export <name> {#.doc (code.text ($_ text@compose "Reads a JSON value as " <desc> "."))} (Parser <type>) (do //.monad - [head any] + [head ..any] (case head (<tag> value) (wrap value) _ - (fail ($_ text@compose "JSON value is not " <desc> ".")))))] + (//.fail (exception.construct ..unexpected-value [head])))))] - [null Any #/.Null "null"] - [boolean Bit #/.Boolean "boolean"] - [number Frac #/.Number "number"] - [string Text #/.String "string"] + [null /.Null #/.Null "null"] + [boolean /.Boolean #/.Boolean "boolean"] + [number /.Number #/.Number "number"] + [string /.String #/.String "string"] ) -(template [<test> <check> <type> <eq> <encoder> <tag> <desc>] +(exception: #export [a] (value-mismatch {reference JSON} {sample JSON}) + (exception.report + ["Reference" (/.format reference)] + ["Sample" (/.format sample)])) + +(template [<test> <check> <type> <equivalence> <tag> <desc>] [(def: #export (<test> test) {#.doc (code.text ($_ text@compose "Asks whether a JSON value is a " <desc> "."))} (-> <type> (Parser Bit)) (do //.monad - [head any] + [head ..any] (case head (<tag> value) - (wrap (:: <eq> = test value)) + (wrap (:: <equivalence> = test value)) _ - (fail ($_ text@compose "JSON value is not " <desc> "."))))) + (//.fail (exception.construct ..unexpected-value [head]))))) (def: #export (<check> test) {#.doc (code.text ($_ text@compose "Ensures a JSON value is a " <desc> "."))} (-> <type> (Parser Any)) (do //.monad - [head any] + [head ..any] (case head (<tag> value) - (if (:: <eq> = test value) + (if (:: <equivalence> = test value) (wrap []) - (fail ($_ text@compose "Value mismatch: " (|> test <encoder>) " =/= " (|> value <encoder>)))) + (//.fail (exception.construct ..value-mismatch [(<tag> test) (<tag> value)]))) _ - (fail ($_ text@compose "JSON value is not a " <desc> ".")))))] + (//.fail (exception.construct ..unexpected-value [head])))))] - [boolean? boolean! Bit bit.equivalence (<| /.format #/.Boolean) #/.Boolean "boolean"] - [number? number! Frac frac.equivalence (:: frac.decimal encode) #/.Number "number"] - [string? string! Text text.equivalence text.encode #/.String "string"] + [boolean? boolean! /.Boolean bit.equivalence #/.Boolean "boolean"] + [number? number! /.Number frac.equivalence #/.Number "number"] + [string? string! /.String text.equivalence #/.String "string"] ) (def: #export (nullable parser) (All [a] (-> (Parser a) (Parser (Maybe a)))) - (//.or null + (//.or ..null parser)) (def: #export (array parser) {#.doc "Parses a JSON array."} (All [a] (-> (Parser a) (Parser a))) (do //.monad - [head any] + [head ..any] (case head (#/.Array values) (case (//.run parser (row.to-list values)) (#try.Failure error) - (fail error) + (//.fail error) (#try.Success [remainder output]) (case remainder @@ -133,16 +137,16 @@ (wrap output) _ - (fail (exception.construct unconsumed-input remainder)))) + (//.fail (exception.construct ..unconsumed-input remainder)))) _ - (fail (text@compose "JSON value is not an array: " (/.format head)))))) + (//.fail (exception.construct ..unexpected-value [head]))))) (def: #export (object parser) {#.doc "Parses a JSON object. Use this with the 'field' combinator."} (All [a] (-> (Parser a) (Parser a))) (do //.monad - [head any] + [head ..any] (case head (#/.Object kvs) (case (|> kvs @@ -152,7 +156,7 @@ list.concat (//.run parser)) (#try.Failure error) - (fail error) + (//.fail error) (#try.Success [remainder output]) (case remainder @@ -160,10 +164,10 @@ (wrap output) _ - (fail (exception.construct unconsumed-input remainder)))) + (//.fail (exception.construct ..unconsumed-input remainder)))) _ - (fail (text@compose "JSON value is not an object: " (/.format head)))))) + (//.fail (exception.construct ..unexpected-value [head]))))) (def: #export (field field-name parser) {#.doc "Parses a field inside a JSON object. Use this inside the 'object' combinator."} @@ -177,7 +181,7 @@ (#try.Success [inputs' output]) (#try.Success [inputs'' _]) - (exception.throw unconsumed-input inputs'') + (exception.throw ..unconsumed-input inputs'') (#try.Failure error) (#try.Failure error)) @@ -187,15 +191,15 @@ output]))) #.Nil - (exception.throw empty-input []) + (exception.throw ..empty-input []) _ - (exception.throw unconsumed-input inputs)))) + (exception.throw ..unconsumed-input inputs)))) (def: #export dictionary {#.doc "Parses a dictionary-like JSON object."} (All [a] (-> (Parser a) (Parser (Dictionary Text a)))) (|>> (//.and ..string) //.some - object + ..object (//@map (dictionary.from-list text.hash)))) diff --git a/stdlib/source/lux/data/format/json.lux b/stdlib/source/lux/data/format/json.lux index 11aa27d3c..e0975d02d 100644 --- a/stdlib/source/lux/data/format/json.lux +++ b/stdlib/source/lux/data/format/json.lux @@ -154,7 +154,9 @@ [get-object #Object Object "objects"] ) -(structure: #export equivalence (Equivalence JSON) +(structure: #export equivalence + (Equivalence JSON) + (def: (= x y) (case [x y] [#Null #Null] @@ -361,6 +363,8 @@ (-> Any (Parser JSON)) ($_ p.or null~ boolean~ number~ string~ (array~ json~') (object~ json~'))) -(structure: #export codec (Codec Text JSON) +(structure: #export codec + (Codec Text JSON) + (def: encode ..format) (def: decode (l.run (json~' [])))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/analysis.lux b/stdlib/source/lux/tool/compiler/language/lux/analysis.lux index 71009473a..f3dc89993 100644 --- a/stdlib/source/lux/tool/compiler/language/lux/analysis.lux +++ b/stdlib/source/lux/tool/compiler/language/lux/analysis.lux @@ -39,14 +39,16 @@ (#Frac Frac) (#Text Text)) -(type: #export Tag Nat) +(type: #export Tag + Nat) (type: #export (Variant a) {#lefts Nat #right? Bit #value a}) -(type: #export (Tuple a) (List a)) +(type: #export (Tuple a) + (List a)) (type: #export (Composite a) (#Variant (Variant a)) @@ -186,21 +188,26 @@ [control/case #..Case] ) -(template [<name> <type> <tag>] +(template: #export (unit) + (#..Primitive #..Unit)) + +(template [<name> <tag>] [(template: #export (<name> value) (#..Primitive (<tag> value)))] - [bit Bit #..Bit] - [nat Nat #..Nat] - [int Int #..Int] - [rev Rev #..Rev] - [frac Frac #..Frac] - [text Text #..Text] + [bit #..Bit] + [nat #..Nat] + [int #..Int] + [rev #..Rev] + [frac #..Frac] + [text #..Text] ) -(type: #export (Abstraction c) [Environment Arity c]) +(type: #export (Abstraction c) + [Environment Arity c]) -(type: #export (Application c) [c (List c)]) +(type: #export (Application c) + [c (List c)]) (def: (last? size tag) (-> Nat Tag Bit) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/synthesis/case.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/synthesis/case.lux index 3e2bbd321..3c80060c2 100644 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/synthesis/case.lux +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/synthesis/case.lux @@ -184,12 +184,6 @@ (#///analysis.Reference (///reference.local <output>))] (list)]) -(def: #export (synthesize-masking synthesize archive input @variable @output) - (-> Phase Archive Synthesis Register Register (Operation Synthesis)) - (if (n.= @variable @output) - (///@wrap input) - (..synthesize-case synthesize archive input (!masking @variable @output)))) - (def: #export (synthesize-let synthesize archive input @variable body) (-> Phase Archive Synthesis Register Analysis (Operation Synthesis)) (do ///.monad @@ -197,6 +191,12 @@ (synthesize archive body))] (wrap (/.branch/let [input @variable body])))) +(def: #export (synthesize-masking synthesize archive input @variable @output) + (-> Phase Archive Synthesis Register Register (Operation Synthesis)) + (if (n.= @variable @output) + (///@wrap input) + (..synthesize-let synthesize archive input @variable (#///analysis.Reference (///reference.local @output))))) + (def: #export (synthesize-if synthesize archive test then else) (-> Phase Archive Synthesis Analysis Analysis (Operation Synthesis)) (do ///.monad diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/synthesis/function.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/synthesis/function.lux index 358a63c31..896ec2161 100644 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/synthesis/function.lux +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/synthesis/function.lux @@ -5,7 +5,7 @@ [control ["." exception (#+ exception:)]] [data - ["." maybe] + ["." maybe ("#@." functor)] ["." text ["%" format (#+ format)]] [number @@ -59,6 +59,19 @@ [locals /.locals] (wrap (|> functionS (//loop.optimization true locals argsS) + (maybe@map (: (-> Synthesis Synthesis) + (function (_ synthesis) + (case synthesis + (^ (<| /.loop/scope [start inits] + /.loop/scope [start' inits'] + output)) + (if (and (n.= start start') + (list.empty? inits')) + (/.loop/scope [start inits output]) + synthesis) + + _ + synthesis)))) (maybe.default <apply>)))) (wrap <apply>)) diff --git a/stdlib/source/lux/tool/compiler/language/lux/synthesis.lux b/stdlib/source/lux/tool/compiler/language/lux/synthesis.lux index c010b05c3..590653281 100644 --- a/stdlib/source/lux/tool/compiler/language/lux/synthesis.lux +++ b/stdlib/source/lux/tool/compiler/language/lux/synthesis.lux @@ -397,7 +397,7 @@ (#Extension [name args]) (|> (list@map %synthesis args) (text.join-with " ") - (format (%.text name)) + (format (%.text name) " ") (text.enclose ["(" ")"])))) (def: #export %path diff --git a/stdlib/source/lux/tool/compiler/reference/variable.lux b/stdlib/source/lux/tool/compiler/reference/variable.lux index e0c814e8d..cea605e93 100644 --- a/stdlib/source/lux/tool/compiler/reference/variable.lux +++ b/stdlib/source/lux/tool/compiler/reference/variable.lux @@ -12,7 +12,8 @@ [text ["%" format (#+ Format)]]]]) -(type: #export Register Nat) +(type: #export Register + Nat) (type: #export Variable (#Local Register) diff --git a/stdlib/source/poly/lux/data/format/json.lux b/stdlib/source/poly/lux/data/format/json.lux index e23d5648c..d3a32b27a 100644 --- a/stdlib/source/poly/lux/data/format/json.lux +++ b/stdlib/source/poly/lux/data/format/json.lux @@ -56,22 +56,25 @@ (def: low-mask Nat (|> 1 (i64.left-shift 32) dec)) (def: high-mask Nat (|> low-mask (i64.left-shift 32))) -(structure: nat-codec (codec.Codec JSON Nat) +(structure: nat-codec + (codec.Codec JSON Nat) + (def: (encode input) (let [high (|> input (i64.and high-mask) (i64.logic-right-shift 32)) low (i64.and low-mask input)] (#/.Array (row (|> high .int int.frac #/.Number) (|> low .int int.frac #/.Number))))) - (def: (decode input) - (<| (</>.run input) - </>.array - (do p.monad - [high </>.number - low </>.number]) - (wrap (n.+ (|> high frac.int .nat (i64.left-shift 32)) - (|> low frac.int .nat)))))) + (def: decode + (</>.run (</>.array + (do p.monad + [high </>.number + low </>.number] + (wrap (n.+ (|> high frac.int .nat (i64.left-shift 32)) + (|> low frac.int .nat)))))))) -(structure: int-codec (codec.Codec JSON Int) +(structure: int-codec + (codec.Codec JSON Int) + (def: encode (|>> .nat (:: nat-codec encode))) (def: decode (|>> (:: nat-codec decode) (:: e.functor map .int)))) @@ -85,7 +88,8 @@ (#.Some value) (writer value)))) (structure: qty-codec - (All [unit] (codec.Codec JSON (unit.Qty unit))) + (All [unit] + (codec.Codec JSON (unit.Qty unit))) (def: encode (|>> unit.out (:: ..int-codec encode))) @@ -322,11 +326,9 @@ #dictionary (Dictionary Text Frac)}) (derived: (..codec Record)))} - (with-gensyms [g!inputs] - (wrap (list (` (: (codec.Codec /.JSON (~ inputT)) - (structure (def: (~' encode) - (..codec//encode (~ inputT))) - (def: ((~' decode) (~ g!inputs)) - ((~! </>.run) (~ g!inputs) - (..codec//decode (~ inputT)))) - ))))))) + (wrap (list (` (: (codec.Codec /.JSON (~ inputT)) + (structure (def: (~' encode) + (..codec//encode (~ inputT))) + (def: (~' decode) + ((~! </>.run) (..codec//decode (~ inputT)))) + )))))) diff --git a/stdlib/source/test/lux/control.lux b/stdlib/source/test/lux/control.lux index bad67d90a..80a94be6f 100644 --- a/stdlib/source/test/lux/control.lux +++ b/stdlib/source/test/lux/control.lux @@ -22,9 +22,10 @@ ["#." parser ["#/." analysis] ["#/." binary] - ["#/." text] ["#/." cli] - ["#/." code]] + ["#/." code] + ["#/." json] + ["#/." text]] ["#." pipe] ["#." reader] ["#." region] @@ -62,9 +63,10 @@ /parser.test /parser/analysis.test /parser/binary.test - /parser/text.test /parser/cli.test /parser/code.test + /parser/json.test + /parser/text.test )) (def: security diff --git a/stdlib/source/test/lux/control/parser/json.lux b/stdlib/source/test/lux/control/parser/json.lux new file mode 100644 index 000000000..dbda12366 --- /dev/null +++ b/stdlib/source/test/lux/control/parser/json.lux @@ -0,0 +1,158 @@ +(.module: + [lux #* + ["_" test (#+ Test)] + [abstract + [monad (#+ do)]] + [control + [pipe (#+ case>)] + ["." try] + ["." exception] + ["<>" parser]] + [data + ["." maybe] + ["." bit] + ["." text] + [number + ["n" nat] + ["." frac]] + [collection + ["." list ("#@." functor)] + ["." set] + ["." dictionary] + ["." row (#+ row) ("#@." functor)]] + [format + ["." json]]] + [math + ["." random (#+ Random)]]] + {1 + ["." /]}) + +(template: (!expect <pattern> <value>) + (case <value> + <pattern> + true + + _ + false)) + +(def: #export test + Test + (<| (_.covering /._) + (_.with-cover [/.Parser]) + (`` ($_ _.and + (do {@ random.monad} + [expected (:: @ map (|>> #json.String) (random.unicode 1))] + (_.cover [/.run /.any] + (|> (/.run /.any expected) + (!expect (^multi (#try.Success actual) + (:: json.equivalence = expected actual)))))) + (_.cover [/.null] + (|> (/.run /.null #json.Null) + (!expect (#try.Success _)))) + (~~ (template [<query> <test> <check> <random> <json> <equivalence>] + [(do {@ random.monad} + [expected <random> + dummy (|> <random> (random.filter (|>> (:: <equivalence> = expected) not)))] + ($_ _.and + (_.cover [<query>] + (|> (/.run <query> (<json> expected)) + (!expect (^multi (#try.Success actual) + (:: <equivalence> = expected actual))))) + (_.cover [<test>] + (and (|> (/.run (<test> expected) (<json> expected)) + (!expect (#try.Success #1))) + (|> (/.run (<test> expected) (<json> dummy)) + (!expect (#try.Success #0))))) + (_.cover [<check>] + (and (|> (/.run (<check> expected) (<json> expected)) + (!expect (#try.Success _))) + (|> (/.run (<check> expected) (<json> dummy)) + (!expect (#try.Failure _)))))))] + + [/.boolean /.boolean? /.boolean! random.bit #json.Boolean bit.equivalence] + [/.number /.number? /.number! random.frac #json.Number frac.equivalence] + [/.string /.string? /.string! (random.unicode 1) #json.String text.equivalence] + )) + (do {@ random.monad} + [expected (random.unicode 1) + dummy random.bit] + (_.cover [/.unexpected-value] + (|> (/.run /.string (#json.Boolean dummy)) + (!expect (^multi (#try.Failure error) + (exception.match? /.unexpected-value error)))))) + (do {@ random.monad} + [expected (random.unicode 1) + dummy (|> (random.unicode 1) (random.filter (|>> (:: text.equivalence = expected) not)))] + (_.cover [/.value-mismatch] + (|> (/.run (/.string! expected) (#json.String dummy)) + (!expect (^multi (#try.Failure error) + (exception.match? /.value-mismatch error)))))) + (do {@ random.monad} + [expected (random.unicode 1)] + (_.cover [/.nullable] + (and (|> (/.run (/.nullable /.string) #json.Null) + (!expect (^multi (#try.Success actual) + (:: (maybe.equivalence text.equivalence) = #.None actual)))) + (|> (/.run (/.nullable /.string) (#json.String expected)) + (!expect (^multi (#try.Success actual) + (:: (maybe.equivalence text.equivalence) = (#.Some expected) actual))))))) + (do {@ random.monad} + [size (:: @ map (n.% 10) random.nat) + expected (|> (random.unicode 1) + (random.list size) + (:: @ map row.from-list))] + (_.cover [/.array] + (|> (/.run (/.array (<>.some /.string)) + (#json.Array (row@map (|>> #json.String) expected))) + (!expect (^multi (#try.Success actual) + (:: (row.equivalence text.equivalence) = expected (row.from-list actual))))))) + (do {@ random.monad} + [expected (:: @ map (|>> #json.String) (random.unicode 1))] + (_.cover [/.unconsumed-input] + (|> (/.run (/.array /.any) (#json.Array (row expected expected))) + (!expect (^multi (#try.Failure error) + (exception.match? /.unconsumed-input error)))))) + (_.cover [/.empty-input] + (|> (/.run (/.array /.any) (#json.Array (row))) + (!expect (^multi (#try.Failure error) + (exception.match? /.empty-input error))))) + (do {@ random.monad} + [expected-boolean random.bit + expected-number random.frac + expected-string (random.unicode 1) + [boolean-field number-field string-field] (|> (random.set text.hash 3 (random.unicode 3)) + (:: @ map (|>> set.to-list + (case> (^ (list boolean-field number-field string-field)) + [boolean-field number-field string-field] + + _ + (undefined)))))] + (_.cover [/.object /.field] + (|> (/.run (/.object ($_ <>.and + (/.field boolean-field /.boolean) + (/.field number-field /.number) + (/.field string-field /.string))) + (#json.Object + (dictionary.from-list text.hash + (list [boolean-field (#json.Boolean expected-boolean)] + [number-field (#json.Number expected-number)] + [string-field (#json.String expected-string)])))) + (!expect (^multi (#try.Success [actual-boolean actual-number actual-string]) + (and (:: bit.equivalence = expected-boolean actual-boolean) + (:: frac.equivalence = expected-number actual-number) + (:: text.equivalence = expected-string actual-string))))))) + (do {@ random.monad} + [size (:: @ map (n.% 10) random.nat) + keys (random.list size (random.unicode 1)) + values (random.list size (random.unicode 1)) + #let [expected (dictionary.from-list text.hash (list.zip2 keys values))]] + (_.cover [/.dictionary] + (|> (/.run (/.dictionary /.string) + (#json.Object + (|> values + (list@map (|>> #json.String)) + (list.zip2 keys) + (dictionary.from-list text.hash)))) + (!expect (^multi (#try.Success actual) + (:: (dictionary.equivalence text.equivalence) = expected actual)))))) + )))) diff --git a/stdlib/source/test/lux/tool/compiler/language/lux/phase/synthesis/function.lux b/stdlib/source/test/lux/tool/compiler/language/lux/phase/synthesis/function.lux index 7350881b1..5b092ce51 100644 --- a/stdlib/source/test/lux/tool/compiler/language/lux/phase/synthesis/function.lux +++ b/stdlib/source/test/lux/tool/compiler/language/lux/phase/synthesis/function.lux @@ -1,23 +1,23 @@ (.module: [lux #* + ["_" test (#+ Test)] [abstract ["." monad (#+ do)]] - [data - ["." name]] - ["r" math/random (#+ Random) ("#@." monad)] - ["_" test (#+ Test)] [control - pipe ["." try]] [data ["." product] ["." maybe] + ["." text + ["%" format (#+ format)]] [number ["n" nat]] [collection - ["." list ("#@." functor fold)] + ["." list ("#@." functor fold monoid)] ["." dictionary (#+ Dictionary)] - ["." set]]]] + ["." set]]] + [math + ["." random (#+ Random)]]] ["." // #_ ["#." primitive]] {1 @@ -27,164 +27,437 @@ [extension ["#." bundle]] ["/#" // - ["#." analysis (#+ Analysis)] - ["#." synthesis (#+ Synthesis)] + ["." analysis (#+ Analysis)] + ["." synthesis (#+ Synthesis)] [/// [arity (#+ Arity)] - ["#." reference + ["." reference ["." variable (#+ Variable) ("#@." equivalence)]] ["." phase] [meta ["." archive]]]]]]]}) -(def: constant-function - (Random [Arity Analysis Analysis]) - (r.rec - (function (_ constant-function) - (do {@ r.monad} - [function? r.bit] - (if function? - (do @ - [[arity bodyA predictionA] constant-function] - (wrap [(inc arity) - (#////analysis.Function (list) bodyA) - predictionA])) - (do @ - [predictionA //primitive.primitive] - (wrap [0 predictionA predictionA]))))))) - -(def: (pick scope-size) - (-> Nat (Random Nat)) - (|> r.nat (:: r.monad map (n.% scope-size)))) - -(def: function-with-environment - (Random [Arity Analysis Variable]) - (do {@ r.monad} - [num-locals (|> r.nat (:: @ map (|>> (n.% 100) (n.max 10)))) - #let [indices (list.n/range 0 (dec num-locals)) - local-env (list@map (|>> #variable.Local) indices) - foreign-env (list@map (|>> #variable.Foreign) indices)] - [arity bodyA predictionA] (: (Random [Arity Analysis Variable]) - (loop [arity 1 - current-env foreign-env] - (let [current-env/size (list.size current-env) - resolver (list@fold (function (_ [idx var] resolver) - (dictionary.put idx var resolver)) - (: (Dictionary Nat Variable) - (dictionary.new n.hash)) - (list.enumerate current-env))] - (do @ - [nest? r.bit] - (if nest? - (do @ - [num-picks (:: @ map (n.max 1) (pick (inc current-env/size))) - picks (|> (r.set n.hash num-picks (pick current-env/size)) - (:: @ map set.to-list)) - [arity bodyA predictionA] (recur (inc arity) - (list@map (function (_ pick) - (maybe.assume (list.nth pick current-env))) - picks)) - #let [picked-env (list@map (|>> #variable.Foreign) picks)]] - (wrap [arity - (#////analysis.Function picked-env bodyA) - predictionA])) - (do @ - [chosen (pick (list.size current-env))] - (wrap [arity - (#////analysis.Reference (////reference.foreign chosen)) - (maybe.assume (dictionary.get chosen resolver))])))))))] - (wrap [arity - (#////analysis.Function local-env bodyA) - predictionA]))) - -(def: local-function - (Random [Arity Analysis Variable]) - (loop [arity 0 - nest? #1] - (if nest? - (do r.monad - [nest?' r.bit - [arity' bodyA predictionA] (recur (inc arity) nest?')] - (wrap [arity' - (#////analysis.Function (list) bodyA) - predictionA])) - (do {@ r.monad} - [chosen (|> r.nat (:: @ map (|>> (n.% 100) (n.max 2))))] - (wrap [arity - (#////analysis.Reference (////reference.local chosen)) - (|> chosen (n.+ (dec arity)) #variable.Local)]))))) +(def: (n-function loop? arity body) + (-> Bit Arity Synthesis Synthesis) + (synthesis.function/abstraction + {#synthesis.environment (list) + #synthesis.arity arity + #synthesis.body (if loop? + (synthesis.loop/scope + {#synthesis.start 1 + #synthesis.inits (list) + #synthesis.iteration body}) + body)})) + +(def: (n-abstraction arity body) + (-> Arity Analysis Analysis) + (list@fold (function (_ arity-1 body) + (case arity-1 + 0 (#analysis.Function (list) body) + _ (#analysis.Function ($_ list@compose + (list@map (|>> #variable.Foreign) + (list.indices arity-1)) + (list (#variable.Local 1))) + body))) + body + (list.reverse (list.indices arity)))) + +(template: (!expect <pattern> <value>) + (case <value> + <pattern> + true + + _ + false)) + +(type: Circumstance + {#loop? Bit + #expectation Synthesis + #reality Analysis}) + +(type: Scenario + (-> Bit (Random Circumstance))) + +(def: (random-unit output?) + Scenario + (:: random.monad wrap + [true + (synthesis.text synthesis.unit) + (analysis.unit)])) + +(template [<name> <random> <synthesis> <analysis>] + [(def: (<name> output?) + Scenario + (do {@ random.monad} + [value <random>] + (wrap [true + (<synthesis> value) + (<analysis> value)])))] + + [random-bit random.bit synthesis.bit analysis.bit] + [random-nat random.nat (|>> .i64 synthesis.i64) analysis.nat] + [random-int random.int (|>> .i64 synthesis.i64) analysis.int] + [random-rev random.rev (|>> .i64 synthesis.i64) analysis.rev] + [random-frac random.frac synthesis.f64 analysis.frac] + [random-text (random.unicode 1) synthesis.text analysis.text] + ) + +(def: (random-primitive output?) + Scenario + (random.either (random.either (..random-unit output?) + (random.either (..random-bit output?) + (..random-nat output?))) + (random.either (random.either (..random-int output?) + (..random-rev output?)) + (random.either (..random-frac output?) + (..random-text output?))))) + +(def: (random-variant random-value output?) + (-> Scenario Scenario) + (do {@ random.monad} + [lefts random.nat + right? random.bit + [loop? expected-value actual-value] (random-value false)] + (wrap [loop? + (synthesis.variant + {#analysis.lefts lefts + #analysis.right? right? + #analysis.value expected-value}) + (analysis.variant + {#analysis.lefts lefts + #analysis.right? right? + #analysis.value actual-value})]))) + +(def: (random-tuple random-value output?) + (-> Scenario Scenario) + (do {@ random.monad} + [[loop?-left expected-left actual-left] (random-value false) + [loop?-right expected-right actual-right] (random-value false)] + (wrap [(and loop?-left + loop?-right) + (synthesis.tuple (list expected-left expected-right)) + (analysis.tuple (list actual-left actual-right))]))) + +(def: (random-structure random-value output?) + (-> Scenario Scenario) + ($_ random.either + (..random-variant random-value output?) + (..random-tuple random-value output?))) + +(def: (random-variable arity output?) + (-> Arity Scenario) + (do {@ random.monad} + [register (:: @ map (|>> (n.% arity) inc) random.nat)] + (wrap [(not (n.= 0 register)) + (synthesis.variable/local register) + (if (n.= arity register) + (#analysis.Reference (reference.local 1)) + (#analysis.Reference (reference.foreign register)))]))) + +(def: (random-constant output?) + Scenario + (do {@ random.monad} + [module (random.unicode 1) + short (random.unicode 1)] + (wrap [true + (synthesis.constant [module short]) + (#analysis.Reference (reference.constant [module short]))]))) + +(def: (random-reference arity output?) + (-> Arity Scenario) + (random.either (..random-variable arity output?) + (..random-constant output?))) + +(def: (random-case arity random-value output?) + (-> Arity Scenario Scenario) + (do {@ random.monad} + [bit-test random.bit + i64-test random.nat + f64-test random.frac + text-test (random.unicode 1) + [loop?-input expected-input actual-input] (random-value false) + [loop?-output expected-output actual-output] (random-value output?) + lefts (|> random.nat (:: @ map (n.% 10))) + right? random.bit + #let [side|member (if right? + (#.Right lefts) + (#.Left lefts))]] + (wrap [(and loop?-input + loop?-output) + (synthesis.branch/case [expected-input + ($_ synthesis.path/alt + (synthesis.path/then expected-output) + (synthesis.path/seq (synthesis.path/bit bit-test) + (synthesis.path/then expected-output)) + (synthesis.path/seq (synthesis.path/i64 (.i64 i64-test)) + (synthesis.path/then expected-output)) + (synthesis.path/seq (synthesis.path/f64 f64-test) + (synthesis.path/then expected-output)) + (synthesis.path/seq (synthesis.path/text text-test) + (synthesis.path/then expected-output)) + (synthesis.path/seq (synthesis.path/bind (inc arity)) + (synthesis.path/then expected-output)) + ($_ synthesis.path/seq + (synthesis.path/side side|member) + (synthesis.path/bind (inc arity)) + (synthesis.path/then expected-output)) + (if right? + ($_ synthesis.path/seq + (synthesis.path/member side|member) + (synthesis.path/bind (inc arity)) + (synthesis.path/then expected-output)) + ($_ synthesis.path/seq + (synthesis.path/member side|member) + (synthesis.path/bind (inc arity)) + synthesis.path/pop + (synthesis.path/then expected-output))))]) + (#analysis.Case actual-input + [{#analysis.when (analysis.pattern/unit) + #analysis.then actual-output} + (list {#analysis.when (analysis.pattern/bit bit-test) + #analysis.then actual-output} + {#analysis.when (analysis.pattern/nat (.nat i64-test)) + #analysis.then actual-output} + {#analysis.when (analysis.pattern/frac f64-test) + #analysis.then actual-output} + {#analysis.when (analysis.pattern/text text-test) + #analysis.then actual-output} + {#analysis.when (#analysis.Bind 2) + #analysis.then actual-output} + {#analysis.when (analysis.pattern/variant + {#analysis.lefts lefts + #analysis.right? right? + #analysis.value (#analysis.Bind 2)}) + #analysis.then actual-output} + {#analysis.when (analysis.pattern/tuple + (list@compose (list.repeat lefts (analysis.pattern/unit)) + (if right? + (list (analysis.pattern/unit) (#analysis.Bind 2)) + (list (#analysis.Bind 2) (analysis.pattern/unit))))) + #analysis.then actual-output})])]))) + +(def: (random-let arity random-value output?) + (-> Arity Scenario Scenario) + (do {@ random.monad} + [[loop?-input expected-input actual-input] (random-value false) + [loop?-output expected-output actual-output] (random-value output?)] + (wrap [(and loop?-input + loop?-output) + (synthesis.branch/let [expected-input + (inc arity) + expected-output]) + (#analysis.Case actual-input + [{#analysis.when (#analysis.Bind 2) + #analysis.then actual-output} + (list)])]))) + +(def: (random-if random-value output?) + (-> Scenario Scenario) + (do {@ random.monad} + [[loop?-test expected-test actual-test] (random-value false) + [loop?-then expected-then actual-then] (random-value output?) + [loop?-else expected-else actual-else] (random-value output?) + flip? random.bit] + (wrap [(and loop?-test + loop?-then + loop?-else) + (synthesis.branch/if [expected-test + expected-then + expected-else]) + (if flip? + (#analysis.Case actual-test + [{#analysis.when (analysis.pattern/bit false) + #analysis.then actual-else} + (list {#analysis.when (analysis.pattern/bit true) + #analysis.then actual-then})]) + (#analysis.Case actual-test + [{#analysis.when (analysis.pattern/bit true) + #analysis.then actual-then} + (list {#analysis.when (analysis.pattern/bit false) + #analysis.then actual-else})]))]))) + +(def: (random-get random-value output?) + (-> Scenario Scenario) + (do {@ random.monad} + [lefts (|> random.nat (:: @ map (n.% 10))) + right? random.bit + [loop?-record expected-record actual-record] (random-value false)] + (wrap [loop?-record + (synthesis.branch/get [(list (if right? + (#.Right lefts) + (#.Left lefts))) + expected-record]) + (#analysis.Case actual-record + [{#analysis.when (analysis.pattern/tuple + (list@compose (list.repeat lefts (analysis.pattern/unit)) + (if right? + (list (analysis.pattern/unit) (#analysis.Bind 2)) + (list (#analysis.Bind 2) (analysis.pattern/unit))))) + #analysis.then (#analysis.Reference (reference.local 2))} + (list)])]))) + +(def: (random-branch arity random-value output?) + (-> Arity Scenario Scenario) + (random.either (random.either (..random-case arity random-value output?) + (..random-let arity random-value output?)) + (random.either (..random-if random-value output?) + (..random-get random-value output?)))) + +(def: (random-recur arity random-value output?) + (-> Arity Scenario Scenario) + (do {@ random.monad} + [resets (random.list arity (random-value false))] + (wrap [true + (synthesis.loop/recur (list@map (|>> product.right product.left) resets)) + (analysis.apply [(#analysis.Reference (case arity + 1 (reference.local 0) + _ (reference.foreign 0))) + (list@map (|>> product.right product.right) resets)])]))) + +(def: (random-scope arity output?) + (-> Arity Scenario) + (do {@ random.monad} + [resets (random.list arity (..random-variable arity output?)) + [_ expected-output actual-output] (..random-nat output?)] + (wrap [(list@fold (function (_ new old) + (and new old)) + true + (list@map product.left resets)) + (synthesis.loop/scope + {#synthesis.start (inc arity) + #synthesis.inits (list@map (|>> product.right product.left) resets) + #synthesis.iteration expected-output}) + (analysis.apply [(..n-abstraction arity actual-output) + (list@map (|>> product.right product.right) resets)])]))) + +(def: (random-loop arity random-value output?) + (-> Arity Scenario Scenario) + (if output? + ($_ random.either + (..random-recur arity random-value output?) + (..random-scope arity output?) + ) + (..random-scope arity output?))) + +(def: (random-abstraction' output?) + Scenario + (do {@ random.monad} + [[loop?-output expected-output actual-output] (..random-nat output?) + arity (|> random.nat (:: @ map (|>> (n.% 5) inc))) + #let [environment ($_ list@compose + (list@map (|>> #variable.Foreign) + (list.indices arity)) + (list (#variable.Local 1)))]] + (wrap [true + (synthesis.function/abstraction + {#synthesis.environment environment + #synthesis.arity 1 + #synthesis.body (synthesis.loop/scope + {#synthesis.start 1 + #synthesis.inits (list) + #synthesis.iteration expected-output})}) + (#analysis.Function environment + actual-output)]))) + +(def: (random-apply random-value output?) + (-> Scenario Scenario) + (do {@ random.monad} + [[loop?-abstraction expected-abstraction actual-abstraction] (..random-nat output?) + arity (|> random.nat (:: @ map (|>> (n.% 5) inc))) + inputs (random.list arity (random-value false))] + (wrap [(list@fold (function (_ new old) + (and new old)) + loop?-abstraction + (list@map product.left inputs)) + (synthesis.function/apply [expected-abstraction + (list@map (|>> product.right product.left) inputs)]) + (analysis.apply [actual-abstraction + (list@map (|>> product.right product.right) inputs)])]))) + +(def: (random-function random-value output?) + (-> Scenario Scenario) + (if output? + (..random-apply random-value output?) + ($_ random.either + (..random-abstraction' output?) + (..random-apply random-value output?) + ))) + +(def: (random-control arity random-value output?) + (-> Arity Scenario Scenario) + ($_ random.either + (..random-branch arity random-value output?) + (..random-loop arity random-value output?) + (..random-function random-value output?) + )) + +(def: (random-extension random-value output?) + (-> Scenario Scenario) + (do {@ random.monad} + [name (random.unicode 1) + [loop?-first expected-first actual-first] (random-value false) + [loop?-second expected-second actual-second] (random-value false) + [loop?-third expected-third actual-third] (random-value false)] + (wrap [(and loop?-first + loop?-second + loop?-third) + (#synthesis.Extension name (list expected-first expected-second expected-third)) + (#analysis.Extension name (list actual-first actual-second actual-third))]))) + +(def: (random-body arity) + (-> Arity Scenario) + (function (random-value output?) + (random.rec + (function (_ _) + ($_ random.either + (..random-primitive output?) + (..random-structure random-value output?) + (..random-reference arity output?) + (..random-control arity random-value output?) + (..random-extension random-value output?)))))) + +(def: random-abstraction + (Random [Synthesis Analysis]) + (do {@ random.monad} + [arity (|> random.nat (:: @ map (|>> (n.% 5) inc))) + [loop? expected-body actual-body] (random-body arity true)] + (wrap [(..n-function loop? arity expected-body) + (..n-abstraction arity actual-body)]))) (def: abstraction Test - (do r.monad - [[arity//constant function//constant prediction//constant] constant-function - [arity//environment function//environment prediction//environment] function-with-environment - [arity//local function//local prediction//local] local-function] - ($_ _.and - (_.test "Nested functions will get folded together." - (|> function//constant - (//.phase archive.empty) - (phase.run [///bundle.empty ////synthesis.init]) - (case> (^ (#try.Success (////synthesis.function/abstraction [environment arity output]))) - (and (n.= arity//constant arity) - (//primitive.corresponds? prediction//constant output)) - - _ - (n.= 0 arity//constant)))) - (_.test "Folded functions provide direct access to environment variables." - (|> function//environment - (//.phase archive.empty) - (phase.run [///bundle.empty ////synthesis.init]) - (case> (^ (#try.Success (////synthesis.function/abstraction [environment arity (#////synthesis.Reference (////reference.variable output))]))) - (and (n.= arity//environment arity) - (variable@= prediction//environment output)) - - _ - #0))) - (_.test "Folded functions properly offset local variables." - (|> function//local - (//.phase archive.empty) - (phase.run [///bundle.empty ////synthesis.init]) - (case> (^ (#try.Success (////synthesis.function/abstraction [environment arity (#////synthesis.Reference (////reference.variable output))]))) - (and (n.= arity//local arity) - (variable@= prediction//local output)) - - _ - #0))) - ))) + (do random.monad + [[expected input] ..random-abstraction] + (_.cover [/.abstraction] + (|> input + (//.phase archive.empty) + (phase.run [///bundle.empty synthesis.init]) + (!expect (^multi (#try.Success actual) + (:: synthesis.equivalence = expected actual))))))) (def: application Test - (do {@ r.monad} - [arity (|> r.nat (:: @ map (|>> (n.% 10) (n.max 1)))) + (do {@ random.monad} + [arity (|> random.nat (:: @ map (|>> (n.% 10) (n.max 1)))) funcA //primitive.primitive - argsA (r.list arity //primitive.primitive)] - ($_ _.and - (_.test "Can synthesize function application." - (|> (////analysis.apply [funcA argsA]) - (//.phase archive.empty) - (phase.run [///bundle.empty ////synthesis.init]) - (case> (^ (#try.Success (////synthesis.function/apply [funcS argsS]))) - (and (//primitive.corresponds? funcA funcS) - (list.every? (product.uncurry //primitive.corresponds?) - (list.zip2 argsA argsS))) - - _ - #0))) - (_.test "Function application on no arguments just synthesizes to the function itself." - (|> (////analysis.apply [funcA (list)]) - (//.phase archive.empty) - (phase.run [///bundle.empty ////synthesis.init]) - (case> (#try.Success funcS) - (//primitive.corresponds? funcA funcS) - - _ - #0))) - ))) + argsA (random.list arity //primitive.primitive)] + (_.cover [/.apply] + (and (|> (analysis.apply [funcA argsA]) + (//.phase archive.empty) + (phase.run [///bundle.empty synthesis.init]) + (!expect (^multi (^ (#try.Success (synthesis.function/apply [funcS argsS]))) + (and (//primitive.corresponds? funcA funcS) + (list.every? (product.uncurry //primitive.corresponds?) + (list.zip2 argsA argsS)))))) + (|> (analysis.apply [funcA (list)]) + (//.phase archive.empty) + (phase.run [///bundle.empty synthesis.init]) + (!expect (^multi (#try.Success funcS) + (//primitive.corresponds? funcA funcS)))))))) (def: #export test Test - (<| (_.context (name.module (name-of /._))) + (<| (_.covering /._) ($_ _.and ..abstraction ..application |