aboutsummaryrefslogtreecommitdiff
path: root/stdlib/source/specification/compositor/generation
diff options
context:
space:
mode:
Diffstat (limited to 'stdlib/source/specification/compositor/generation')
-rw-r--r--stdlib/source/specification/compositor/generation/case.lux288
-rw-r--r--stdlib/source/specification/compositor/generation/common.lux343
-rw-r--r--stdlib/source/specification/compositor/generation/function.lux93
-rw-r--r--stdlib/source/specification/compositor/generation/primitive.lux48
-rw-r--r--stdlib/source/specification/compositor/generation/reference.lux60
-rw-r--r--stdlib/source/specification/compositor/generation/structure.lux89
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)
+ ))