diff options
Diffstat (limited to 'stdlib/source/specification/compositor/generation')
6 files changed, 921 insertions, 0 deletions
diff --git a/stdlib/source/specification/compositor/generation/case.lux b/stdlib/source/specification/compositor/generation/case.lux new file mode 100644 index 000000000..2424aa330 --- /dev/null +++ b/stdlib/source/specification/compositor/generation/case.lux @@ -0,0 +1,288 @@ +(.module: + [lux (#- case) + ["_" test (#+ Test)] + [abstract + [monad (#+ do)]] + [control + [pipe (#+ case>)] + ["." try (#+ Try)]] + [data + ["." text ("#\." equivalence) + ["%" format (#+ format)]] + [number + ["n" nat] + ["f" frac]] + [collection + ["." list ("#\." fold)]]] + [math + ["r" random (#+ Random)]] + [tool + [compiler + ["." reference] + ["." analysis] + ["." synthesis (#+ Path Synthesis)] + ["." phase + ["#/." synthesis + ["." case]] + ["." extension/synthesis]]]]] + [/// + [common (#+ Runner)]]) + +(def: limit Nat 10) + +(def: size + (Random Nat) + (|> r.nat (\ r.monad map (|>> (n.% ..limit) (n.max 2))))) + +(def: (tail? size idx) + (-> Nat Nat Bit) + (n.= (dec size) idx)) + +(def: #export (verify expected) + (-> Frac (Try Any) Bit) + (|>> (case> (#try.Success actual) + (f.= expected (:as Frac actual)) + + (#try.Failure _) + false))) + +(def: case + (Random [Synthesis Path]) + (<| r.rec (function (_ case)) + (`` ($_ r.either + (do r.monad + [value r.i64] + (wrap [(synthesis.i64 value) + synthesis.path/pop])) + (~~ (template [<gen> <synth> <path>] + [(do r.monad + [value <gen>] + (wrap [(<synth> value) + (<path> value)]))] + + [r.bit synthesis.bit synthesis.path/bit] + [r.i64 synthesis.i64 synthesis.path/i64] + [r.frac synthesis.f64 synthesis.path/f64] + [(r.unicode 5) synthesis.text synthesis.path/text])) + (do {! r.monad} + [size ..size + idx (|> r.nat (\ ! map (n.% size))) + [subS subP] case + #let [unitS (synthesis.text synthesis.unit) + caseS (synthesis.tuple + (list.concat (list (list.repeat idx unitS) + (list subS) + (list.repeat (|> size dec (n.- idx)) unitS)))) + caseP ($_ synthesis.path/seq + (if (tail? size idx) + (synthesis.member/right idx) + (synthesis.member/left idx)) + subP)]] + (wrap [caseS caseP])) + (do {! r.monad} + [size ..size + idx (|> r.nat (\ ! map (n.% size))) + [subS subP] case + #let [right? (tail? size idx) + caseS (synthesis.variant + {#analysis.lefts idx + #analysis.right? right? + #analysis.value subS}) + caseP ($_ synthesis.path/seq + (if right? + (synthesis.side/right idx) + (synthesis.side/left idx)) + subP)]] + (wrap [caseS caseP])) + )))) + +(def: (let-spec run) + (-> Runner Test) + (do r.monad + [value r.safe-frac] + (_.test (%.name (name-of synthesis.branch/let)) + (|> (synthesis.branch/let [(synthesis.f64 value) + 0 + (synthesis.variable/local 0)]) + (run "let-spec") + (verify value))))) + +(def: (if-spec run) + (-> Runner Test) + (do r.monad + [on-true r.safe-frac + on-false (|> r.safe-frac (r.filter (|>> (f.= on-true) not))) + verdict r.bit] + (_.test (%.name (name-of synthesis.branch/if)) + (|> (synthesis.branch/if [(synthesis.bit verdict) + (synthesis.f64 on-true) + (synthesis.f64 on-false)]) + (run "if-spec") + (verify (if verdict on-true on-false)))))) + +(def: (case-spec run) + (-> Runner Test) + (do r.monad + [[inputS pathS] ..case + on-success r.safe-frac + on-failure (|> r.safe-frac (r.filter (|>> (f.= on-success) not)))] + (_.test (%.name (name-of synthesis.branch/case)) + (|> (synthesis.branch/case + [inputS + ($_ synthesis.path/alt + ($_ synthesis.path/seq + pathS + (synthesis.path/then (synthesis.f64 on-success))) + (synthesis.path/then (synthesis.f64 on-failure)))]) + (run "case-spec") + (verify on-success))))) + +(def: special-input + Synthesis + (let [_cursor_ (: Synthesis + (synthesis.tuple (list (synthesis.text .prelude_module) + (synthesis.i64 +901) + (synthesis.i64 +13)))) + _code_ (: (-> Synthesis Synthesis) + (function (_ content) + (synthesis.tuple (list _cursor_ content)))) + _nil_ (: Synthesis + (synthesis.variant [0 #0 (synthesis.text "")])) + _cons_ (: (-> Synthesis Synthesis Synthesis) + (function (_ head tail) + (synthesis.variant [0 #1 (synthesis.tuple (list head tail))]))) + _list_ (: (-> (List Synthesis) Synthesis) + (list\fold _cons_ _nil_))] + (let [__tuple__ (: (-> (List Synthesis) Synthesis) + (|>> list.reverse _list_ [9 #0] synthesis.variant _code_)) + __form__ (: (-> (List Synthesis) Synthesis) + (|>> list.reverse _list_ [8 #0] synthesis.variant _code_)) + __text__ (: (-> Text Synthesis) + (function (_ value) + (_code_ (synthesis.variant [5 #0 (synthesis.text value)])))) + __identifier__ (: (-> Name Synthesis) + (function (_ [module short]) + (_code_ (synthesis.variant [6 #0 (synthesis.tuple (list (synthesis.text module) + (synthesis.text short)))])))) + __tag__ (: (-> Name Synthesis) + (function (_ [module short]) + (_code_ (synthesis.variant [7 #0 (synthesis.tuple (list (synthesis.text module) + (synthesis.text short)))])))) + __list__ (: (-> (List Synthesis) Synthesis) + (list\fold (function (_ head tail) + (__form__ (list (__tag__ ["" "Cons"]) head tail))) + (__tag__ ["" "Nil"]))) + __apply__ (: (-> Synthesis Synthesis Synthesis) + (function (_ func arg) + (__form__ (list func arg))))] + (|> _nil_ + (_cons_ (__apply__ (__identifier__ ["" "form$"]) + (__list__ (list (__apply__ (__identifier__ ["" "tag$"]) + (__tuple__ (list (__text__ .prelude_module) + (__text__ "Cons")))) + (__identifier__ ["" "export?-meta"]) + (__identifier__ ["" "tail"]))))) + (_cons_ (__tuple__ (list (__identifier__ ["" "tail"])))) + )))) + +(def: special-path + Path + (let [_nil_ (synthesis.path/side (#.Left 0)) + _cons_ (synthesis.path/side (#.Right 0)) + _head_ (synthesis.path/member (#.Left 0)) + _tail_ (synthesis.path/member (#.Right 0)) + _tuple_ (synthesis.path/side (#.Left 9))] + ($_ synthesis.path/alt + ($_ synthesis.path/seq + _cons_ + _head_ + _head_ (synthesis.path/bind 2) synthesis.path/pop + _tail_ _tuple_ _cons_ + _head_ (synthesis.path/bind 3) synthesis.path/pop + _tail_ (synthesis.path/bind 4) synthesis.path/pop + synthesis.path/pop synthesis.path/pop synthesis.path/pop synthesis.path/pop + _tail_ _cons_ + _head_ (synthesis.path/bind 5) synthesis.path/pop + _tail_ _nil_ + ## THEN + (synthesis.path/then (synthesis.bit #1))) + ($_ synthesis.path/seq + (synthesis.path/bind 2) + ## THEN + (synthesis.path/then (synthesis.bit #0)))))) + +(def: special-pattern + analysis.Pattern + (let [## [_ (#Tuple (#Cons arg args'))] + head (<| analysis.pattern/tuple (list (analysis.pattern/bind 2)) + analysis.pattern/variant [9 #0] + analysis.pattern/variant [0 #1] + analysis.pattern/tuple (list (analysis.pattern/bind 3) + (analysis.pattern/bind 4))) + ## (#Cons body #Nil) + tail (<| analysis.pattern/variant [0 #1] + analysis.pattern/tuple (list (analysis.pattern/bind 5)) + analysis.pattern/variant [0 #0] + (analysis.pattern/unit))] + ## (#Cons <head> <tail>) + (<| analysis.pattern/variant [0 #1] + (analysis.pattern/tuple (list head tail))))) + +(def: special-pattern-path + Path + ($_ synthesis.path/alt + (<| try.assume + (phase.run [extension/synthesis.bundle + synthesis.init]) + (case.path phase/synthesis.phase + special-pattern) + (analysis.bit #1)) + ($_ synthesis.path/seq + (synthesis.path/bind 2) + ## THEN + (synthesis.path/then (synthesis.bit #0))))) + +## TODO: Get rid of this ASAP +(def: (special-spec run) + (-> Runner Test) + ($_ _.and + (_.test "===" + (and (text\= (synthesis.%path special-path) + (synthesis.%path special-pattern-path)) + (\ synthesis.path-equivalence = special-path special-pattern-path))) + (_.test "CODE" + (|> special-input + (run "special-input") + (case> (#try.Success output) + true + + (#try.Failure _) + false))) + (_.test "PATTERN-MATCHING 0" + (|> (synthesis.branch/case [special-input + special-path]) + (run "special-path") + (case> (#try.Success output) + true + + (#try.Failure _) + false))) + (_.test "PATTERN-MATCHING 1" + (|> (synthesis.branch/case [special-input + special-pattern-path]) + (run "special-pattern-path") + (case> (#try.Success output) + true + + (#try.Failure _) + false))) + )) + +(def: #export (spec run) + (-> Runner Test) + ($_ _.and + (..special-spec run) + (..let-spec run) + (..if-spec run) + (..case-spec run) + )) diff --git a/stdlib/source/specification/compositor/generation/common.lux b/stdlib/source/specification/compositor/generation/common.lux new file mode 100644 index 000000000..3d377b7ca --- /dev/null +++ b/stdlib/source/specification/compositor/generation/common.lux @@ -0,0 +1,343 @@ +(.module: + [lux (#- i64) + ["_" test (#+ Test)] + [abstract + [monad (#+ do)]] + [control + [pipe (#+ case>)] + ["." try (#+ Try)]] + [data + ["." bit ("#\." equivalence)] + [number + ["." i64] + ["n" nat] + ["i" int] + ["f" frac]] + ["." text ("#\." equivalence) + ["%" format (#+ format)]] + [collection + ["." list]]] + [math + ["r" random (#+ Random)]] + [tool + [compiler + ["." reference] + ["." synthesis]]]] + ["." // #_ + ["#." case] + [// + [common (#+ Runner)]]]) + +(def: sanitize + (-> Text Text) + (text.replace-all " " "_")) + +(def: (bit run) + (-> Runner Test) + (do r.monad + [param r.i64 + subject r.i64] + (with-expansions [<binary> (template [<extension> <reference> <param-expr>] + [(_.test <extension> + (|> (#synthesis.Extension <extension> (list (synthesis.i64 param) + (synthesis.i64 subject))) + (run (..sanitize <extension>)) + (case> (#try.Success valueT) + (n.= (<reference> param subject) (:as Nat valueT)) + + (#try.Failure _) + false) + (let [param <param-expr>])))] + + ["lux i64 and" i64.and param] + ["lux i64 or" i64.or param] + ["lux i64 xor" i64.xor param] + ["lux i64 left-shift" i64.left-shift (n.% 64 param)] + ["lux i64 logical-right-shift" i64.logic-right-shift (n.% 64 param)] + )] + ($_ _.and + <binary> + (_.test "lux i64 arithmetic-right-shift" + (|> (#synthesis.Extension "lux i64 arithmetic-right-shift" + (list (synthesis.i64 subject) + (synthesis.i64 param))) + (run (..sanitize "lux i64 arithmetic-right-shift")) + (case> (#try.Success valueT) + ("lux i64 =" + (i64.arithmetic-right-shift param subject) + (:as I64 valueT)) + + (#try.Failure _) + false) + (let [param (n.% 64 param)]))) + )))) + +(def: (i64 run) + (-> Runner Test) + (do r.monad + [param (|> r.i64 (r.filter (|>> ("lux i64 =" 0) not))) + subject r.i64] + (`` ($_ _.and + (~~ (template [<extension> <type> <prepare> <comp> <subject-expr>] + [(_.test <extension> + (|> (#synthesis.Extension <extension> (list (synthesis.i64 subject))) + (run (..sanitize <extension>)) + (case> (#try.Success valueT) + (<comp> (<prepare> subject) (:as <type> valueT)) + + (#try.Failure _) + false) + (let [subject <subject-expr>])))] + + ["lux i64 f64" Frac i.frac f.= subject] + ["lux i64 char" Text (|>> (:as Nat) text.from-code) text\= (|> subject + (:as Nat) + (n.% (i64.left-shift 8 1)) + (:as Int))] + )) + (~~ (template [<extension> <reference> <outputT> <comp>] + [(_.test <extension> + (|> (#synthesis.Extension <extension> (list (synthesis.i64 param) + (synthesis.i64 subject))) + (run (..sanitize <extension>)) + (case> (#try.Success valueT) + (<comp> (<reference> param subject) (:as <outputT> valueT)) + + (#try.Failure _) + false)))] + + ["lux i64 +" i.+ Int i.=] + ["lux i64 -" i.- Int i.=] + ["lux i64 *" i.* Int i.=] + ["lux i64 /" i./ Int i.=] + ["lux i64 %" i.% Int i.=] + ["lux i64 =" i.= Bit bit\=] + ["lux i64 <" i.< Bit bit\=] + )) + )))) + +(def: simple-frac + (Random Frac) + (|> r.nat (\ r.monad map (|>> (n.% 1000) .int i.frac)))) + +(def: (f64 run) + (-> Runner Test) + (do r.monad + [param (|> ..simple-frac (r.filter (|>> (f.= +0.0) not))) + subject ..simple-frac] + (`` ($_ _.and + (~~ (template [<extension> <reference> <comp>] + [(_.test <extension> + (|> (#synthesis.Extension <extension> (list (synthesis.f64 param) + (synthesis.f64 subject))) + (run (..sanitize <extension>)) + (//case.verify (<reference> param subject))))] + + ["lux f64 +" f.+ f.=] + ["lux f64 -" f.- f.=] + ["lux f64 *" f.* f.=] + ["lux f64 /" f./ f.=] + ["lux f64 %" f.% f.=] + )) + (~~ (template [<extension> <text>] + [(_.test <extension> + (|> (#synthesis.Extension <extension> (list (synthesis.f64 param) + (synthesis.f64 subject))) + (run (..sanitize <extension>)) + (case> (#try.Success valueV) + (bit\= (<text> param subject) + (:as Bit valueV)) + + _ + false)))] + + ["lux f64 =" f.=] + ["lux f64 <" f.<] + )) + (~~ (template [<extension> <reference>] + [(_.test <extension> + (|> (#synthesis.Extension <extension> (list)) + (run (..sanitize <extension>)) + (//case.verify <reference>)))] + + ["lux f64 min" ("lux f64 min")] + ["lux f64 max" ("lux f64 max")] + ["lux f64 smallest" ("lux f64 smallest")] + )) + (_.test "'lux f64 i64 && 'lux i64 f64'" + (|> (run (..sanitize "lux f64 i64") + (|> subject synthesis.f64 + (list) (#synthesis.Extension "lux f64 i64") + (list) (#synthesis.Extension "lux i64 f64"))) + (//case.verify subject))) + )))) + +(def: (text run) + (-> Runner Test) + (do {! r.monad} + [sample-size (|> r.nat (\ ! map (|>> (n.% 10) (n.max 1)))) + sample-lower (r.ascii/lower-alpha sample-size) + sample-upper (r.ascii/upper-alpha sample-size) + sample-alpha (|> (r.ascii/alpha sample-size) + (r.filter (|>> (text\= sample-upper) not))) + char-idx (|> r.nat (\ ! map (n.% sample-size))) + #let [sample-lowerS (synthesis.text sample-lower) + sample-upperS (synthesis.text sample-upper) + sample-alphaS (synthesis.text sample-alpha) + concatenatedS (#synthesis.Extension "lux text concat" (list sample-lowerS sample-upperS)) + pre-rep-once (format sample-lower sample-upper) + post-rep-once (format sample-lower sample-alpha) + pre-rep-all (|> (list.repeat sample-size sample-lower) (text.join-with sample-upper)) + post-rep-all (|> (list.repeat sample-size sample-lower) (text.join-with sample-alpha))]] + ($_ _.and + (_.test "Can compare texts for equality." + (and (|> (#synthesis.Extension "lux text =" (list sample-lowerS sample-lowerS)) + (run (..sanitize "lux text =")) + (case> (#try.Success valueV) + (:as Bit valueV) + + _ + false)) + (|> (#synthesis.Extension "lux text =" (list sample-upperS sample-lowerS)) + (run (..sanitize "lux text =")) + (case> (#try.Success valueV) + (not (:as Bit valueV)) + + _ + false)))) + (_.test "Can compare texts for order." + (|> (#synthesis.Extension "lux text <" (list sample-lowerS sample-upperS)) + (run (..sanitize "lux text <")) + (case> (#try.Success valueV) + (:as Bit valueV) + + (#try.Failure _) + false))) + (_.test "Can get length of text." + (|> (#synthesis.Extension "lux text size" (list sample-lowerS)) + (run (..sanitize "lux text size")) + (case> (#try.Success valueV) + (n.= sample-size (:as Nat valueV)) + + _ + false))) + (_.test "Can concatenate text." + (|> (#synthesis.Extension "lux text size" (list concatenatedS)) + (run (..sanitize "lux text size")) + (case> (#try.Success valueV) + (n.= (n.* 2 sample-size) (:as Nat valueV)) + + _ + false))) + (_.test "Can find index of sub-text." + (and (|> (#synthesis.Extension "lux text index" + (list concatenatedS sample-lowerS + (synthesis.i64 +0))) + (run (..sanitize "lux text index")) + (case> (^multi (#try.Success valueV) + [(:as (Maybe Nat) valueV) (#.Some valueV)]) + (n.= 0 valueV) + + _ + false)) + (|> (#synthesis.Extension "lux text index" + (list concatenatedS sample-upperS + (synthesis.i64 +0))) + (run (..sanitize "lux text index")) + (case> (^multi (#try.Success valueV) + [(:as (Maybe Nat) valueV) (#.Some valueV)]) + (n.= sample-size valueV) + + _ + false)))) + (let [test-clip (: (-> (I64 Any) (I64 Any) Text Bit) + (function (_ offset length expected) + (|> (#synthesis.Extension "lux text clip" + (list concatenatedS + (synthesis.i64 offset) + (synthesis.i64 length))) + (run (..sanitize "lux text clip")) + (case> (^multi (#try.Success valueV) + [(:as (Maybe Text) valueV) (#.Some valueV)]) + (text\= expected valueV) + + _ + false))))] + (_.test "Can clip text to extract sub-text." + (and (test-clip 0 sample-size sample-lower) + (test-clip sample-size sample-size sample-upper)))) + (_.test "Can extract individual characters from text." + (|> (#synthesis.Extension "lux text char" + (list sample-lowerS + (synthesis.i64 char-idx))) + (run (..sanitize "lux text char")) + (case> (^multi (#try.Success valueV) + [(:as (Maybe Int) valueV) (#.Some valueV)]) + (text.contains? ("lux i64 char" valueV) + sample-lower) + + _ + false))) + ))) + +(def: (io run) + (-> Runner Test) + (do r.monad + [message (r.ascii/alpha 5)] + ($_ _.and + (_.test "Can log messages." + (|> (#synthesis.Extension "lux io log" + (list (synthesis.text (format "LOG: " message)))) + (run (..sanitize "lux io log")) + (case> (#try.Success valueV) + true + + (#try.Failure _) + false))) + (_.test "Can throw runtime errors." + (and (|> (#synthesis.Extension "lux try" + (list (synthesis.function/abstraction + {#synthesis.environment (list) + #synthesis.arity 1 + #synthesis.body (#synthesis.Extension "lux io error" + (list (synthesis.text message)))}))) + (run (..sanitize "lux try")) + (case> (^multi (#try.Success valueV) + [(:as (Try Text) valueV) (#try.Failure error)]) + (text.contains? message error) + + _ + false)) + (|> (#synthesis.Extension "lux try" + (list (synthesis.function/abstraction + {#synthesis.environment (list) + #synthesis.arity 1 + #synthesis.body (synthesis.text message)}))) + (run (..sanitize "lux try")) + (case> (^multi (#try.Success valueV) + [(:as (Try Text) valueV) (#try.Success valueV)]) + (text\= message valueV) + + _ + false)))) + (_.test "Can obtain current time in milli-seconds." + (|> (synthesis.tuple (list (#synthesis.Extension "lux io current-time" (list)) + (#synthesis.Extension "lux io current-time" (list)))) + (run (..sanitize "lux io current-time")) + (case> (#try.Success valueV) + (let [[pre post] (:as [Nat Nat] valueV)] + (n.>= pre post)) + + (#try.Failure _) + false))) + ))) + +(def: #export (spec runner) + (-> Runner Test) + ($_ _.and + (..bit runner) + (..i64 runner) + (..f64 runner) + (..text runner) + (..io runner) + )) diff --git a/stdlib/source/specification/compositor/generation/function.lux b/stdlib/source/specification/compositor/generation/function.lux new file mode 100644 index 000000000..6d0f8d541 --- /dev/null +++ b/stdlib/source/specification/compositor/generation/function.lux @@ -0,0 +1,93 @@ +(.module: + [lux (#- function) + ["_" test (#+ Test)] + [abstract + [monad (#+ do)] + ["." enum]] + [control + [pipe (#+ case>)]] + [data + ["." maybe] + [number + ["n" nat]] + [collection + ["." list ("#\." functor)]]] + [math + ["r" random (#+ Random) ("#\." monad)]] + [tool + [compiler + [analysis (#+ Arity)] + ["." reference (#+ Register)] + ["." synthesis (#+ Synthesis)]]]] + ["." // #_ + ["#." case] + [// + [common (#+ Runner)]]]) + +(def: max-arity Arity 10) + +(def: arity + (Random Arity) + (|> r.nat (r\map (|>> (n.% max-arity) (n.max 1))))) + +(def: (local arity) + (-> Arity (Random Register)) + (|> r.nat (r\map (|>> (n.% arity) inc)))) + +(def: function + (Random [Arity Register Synthesis]) + (do r.monad + [arity ..arity + local (..local arity)] + (wrap [arity local + (synthesis.function/abstraction + {#synthesis.environment (list) + #synthesis.arity arity + #synthesis.body (synthesis.variable/local local)})]))) + +(def: #export (spec run) + (-> Runner Test) + (do {! r.monad} + [[arity local functionS] ..function + partial-arity (|> r.nat (\ ! map (|>> (n.% arity) (n.max 1)))) + inputs (r.list arity r.safe-frac) + #let [expectation (maybe.assume (list.nth (dec local) inputs)) + inputsS (list\map (|>> synthesis.f64) inputs)]] + ($_ _.and + (_.test "Can read arguments." + (|> (synthesis.function/apply {#synthesis.function functionS + #synthesis.arguments inputsS}) + (run "with-local") + (//case.verify expectation))) + (_.test "Can partially apply functions." + (or (n.= 1 arity) + (let [preS (list.take partial-arity inputsS) + postS (list.drop partial-arity inputsS) + partialS (synthesis.function/apply {#synthesis.function functionS + #synthesis.arguments preS})] + (|> (synthesis.function/apply {#synthesis.function partialS + #synthesis.arguments postS}) + (run "partial-application") + (//case.verify expectation))))) + (_.test "Can read environment." + (or (n.= 1 arity) + (let [environment (|> partial-arity + (enum.range n.enum 1) + (list\map (|>> #reference.Local))) + variableS (if (n.<= partial-arity local) + (synthesis.variable/foreign (dec local)) + (synthesis.variable/local (|> local (n.- partial-arity)))) + inner-arity (n.- partial-arity arity) + innerS (synthesis.function/abstraction + {#synthesis.environment environment + #synthesis.arity inner-arity + #synthesis.body variableS}) + outerS (synthesis.function/abstraction + {#synthesis.environment (list) + #synthesis.arity partial-arity + #synthesis.body innerS})] + (|> (synthesis.function/apply {#synthesis.function outerS + #synthesis.arguments inputsS}) + (run "with-foreign") + (//case.verify expectation))))) + ))) diff --git a/stdlib/source/specification/compositor/generation/primitive.lux b/stdlib/source/specification/compositor/generation/primitive.lux new file mode 100644 index 000000000..3b6dd657b --- /dev/null +++ b/stdlib/source/specification/compositor/generation/primitive.lux @@ -0,0 +1,48 @@ +(.module: + [lux #* + ["_" test (#+ Test)] + [abstract + [monad (#+ do)]] + [control + [pipe (#+ case>)] + ["." try]] + [data + ["." bit ("#\." equivalence)] + [number + ["f" frac]] + ["." text ("#\." equivalence) + ["%" format (#+ format)]]] + [math + ["r" random]] + [tool + [compiler + ["." synthesis]]]] + [/// + [common (#+ Runner)]]) + +(def: (f/=' reference subject) + (-> Frac Frac Bit) + (or (f.= reference subject) + (and (f.not-a-number? reference) + (f.not-a-number? subject)))) + +(def: #export (spec run) + (-> Runner Test) + (`` ($_ _.and + (~~ (template [<evaluation-name> <synthesis> <gen> <test>] + [(do r.monad + [expected <gen>] + (_.test (%.name (name-of <synthesis>)) + (|> (run <evaluation-name> (<synthesis> expected)) + (case> (#try.Success actual) + (<test> expected (:assume actual)) + + (#try.Failure _) + false))))] + + ["bit" synthesis.bit r.bit bit\=] + ["i64" synthesis.i64 r.i64 "lux i64 ="] + ["f64" synthesis.f64 r.frac f.='] + ["text" synthesis.text (r.ascii 5) text\=] + )) + ))) diff --git a/stdlib/source/specification/compositor/generation/reference.lux b/stdlib/source/specification/compositor/generation/reference.lux new file mode 100644 index 000000000..665175ab4 --- /dev/null +++ b/stdlib/source/specification/compositor/generation/reference.lux @@ -0,0 +1,60 @@ +(.module: + [lux #* + ["_" test (#+ Test)] + [abstract + [monad (#+ do)]] + [control + [pipe (#+ case>)] + ["." try]] + [data + [number + ["n" nat] + ["f" frac]]] + [tool + [compiler + ["." reference] + ["." synthesis]]] + [math + ["r" random (#+ Random)]]] + [/// + [common (#+ Runner Definer)]]) + +(def: name + (Random Name) + (let [name-part (r.ascii/upper-alpha 5)] + [(r.and name-part name-part)])) + +(def: (definition define) + (-> Definer Test) + (do r.monad + [name ..name + expected r.safe-frac] + (_.test "Definitions." + (|> (define name (synthesis.f64 expected)) + (case> (#try.Success actual) + (f.= expected (:as Frac actual)) + + (#try.Failure _) + false))))) + +(def: (variable run) + (-> Runner Test) + (do {! r.monad} + [register (|> r.nat (\ ! map (n.% 100))) + expected r.safe-frac] + (_.test "Local variables." + (|> (synthesis.branch/let [(synthesis.f64 expected) + register + (synthesis.variable/local register)]) + (run "variable") + (case> (#try.Success actual) + (f.= expected (:as Frac actual)) + + (#try.Failure _) + false))))) + +(def: #export (spec runner definer) + (-> Runner Definer Test) + ($_ _.and + (..definition definer) + (..variable runner))) diff --git a/stdlib/source/specification/compositor/generation/structure.lux b/stdlib/source/specification/compositor/generation/structure.lux new file mode 100644 index 000000000..7c45d2a9b --- /dev/null +++ b/stdlib/source/specification/compositor/generation/structure.lux @@ -0,0 +1,89 @@ +(.module: + [lux #* + ["_" test (#+ Test)] + [abstract + [monad (#+ do)]] + [control + [pipe (#+ case>)] + ["." try]] + [data + ["." maybe] + [number + ["n" nat] + ["i" int]] + ["." text ("#\." equivalence) + ["%" format (#+ format)]] + [collection + ["." array (#+ Array)] + ["." list ("#\." functor)]]] + [math + ["r" random]] + ["." ffi (#+ import:)] + [tool + [compiler + ["." analysis] + ["." synthesis]]]] + [/// + [common (#+ Runner)]]) + +(import: java/lang/Integer) + +(def: (variant run) + (-> Runner Test) + (do {! r.monad} + [num-tags (|> r.nat (\ ! map (|>> (n.% 10) (n.max 2)))) + tag-in (|> r.nat (\ ! map (n.% num-tags))) + #let [last?-in (|> num-tags dec (n.= tag-in))] + value-in r.i64] + (_.test (%.name (name-of synthesis.variant)) + (|> (synthesis.variant {#analysis.lefts (if last?-in + (dec tag-in) + tag-in) + #analysis.right? last?-in + #analysis.value (synthesis.i64 value-in)}) + (run "variant") + (case> (#try.Success valueT) + (let [valueT (:as (Array Any) valueT)] + (and (n.= 3 (array.size valueT)) + (let [tag-out (:as java/lang/Integer (maybe.assume (array.read 0 valueT))) + last?-out (array.read 1 valueT) + value-out (:as Any (maybe.assume (array.read 2 valueT))) + same-tag? (|> tag-out ffi.int-to-long (:as Nat) (n.= tag-in)) + same-flag? (case last?-out + (#.Some last?-out') + (and last?-in (text\= "" (:as Text last?-out'))) + + #.None + (not last?-in)) + same-value? (|> value-out (:as Int) (i.= value-in))] + (and same-tag? + same-flag? + same-value?)))) + + (#try.Failure _) + false))))) + +(def: (tuple run) + (-> Runner Test) + (do {! r.monad} + [size (|> r.nat (\ ! map (|>> (n.% 10) (n.max 2)))) + tuple-in (r.list size r.i64)] + (_.test (%.name (name-of synthesis.tuple)) + (|> (synthesis.tuple (list\map (|>> synthesis.i64) tuple-in)) + (run "tuple") + (case> (#try.Success tuple-out) + (let [tuple-out (:as (Array Any) tuple-out)] + (and (n.= size (array.size tuple-out)) + (list.every? (function (_ [left right]) + (i.= left (:as Int right))) + (list.zip/2 tuple-in (array.to-list tuple-out))))) + + (#try.Failure _) + false))))) + +(def: #export (spec runner) + (-> Runner Test) + ($_ _.and + (..variant runner) + (..tuple runner) + )) |