aboutsummaryrefslogtreecommitdiff
path: root/stdlib/source/spec/compositor
diff options
context:
space:
mode:
Diffstat (limited to 'stdlib/source/spec/compositor')
-rw-r--r--stdlib/source/spec/compositor/generation/case.lux284
-rw-r--r--stdlib/source/spec/compositor/generation/function.lux92
2 files changed, 376 insertions, 0 deletions
diff --git a/stdlib/source/spec/compositor/generation/case.lux b/stdlib/source/spec/compositor/generation/case.lux
new file mode 100644
index 000000000..1c398d301
--- /dev/null
+++ b/stdlib/source/spec/compositor/generation/case.lux
@@ -0,0 +1,284 @@
+(.module:
+ [lux (#- case)
+ ["_" test (#+ Test)]
+ [abstract
+ [monad (#+ do)]]
+ [control
+ [pipe (#+ case>)]]
+ [data
+ ["." error (#+ Error)]
+ ["." text ("#@." equivalence)
+ format]
+ [collection
+ ["." list ("#@." fold)]]]
+ [math
+ ["r" random (#+ Random)]]
+ [tool
+ [compiler
+ ["." reference]
+ ["." analysis]
+ ["." synthesis (#+ Path Synthesis)]
+ ["." phase
+ ["#/." synthesis
+ ["." case]]
+ ["." extension/synthesis]]]]]
+ ["." ///])
+
+(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 (Error Any) Bit)
+ (|>> (case> (#error.Success actual)
+ (f/= expected (:coerce Frac actual))
+
+ (#error.Failure error)
+ 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 "lux")
+ (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__ "lux")
+ (__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
+ (<| error.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> (#error.Success output)
+ true
+
+ (#error.Failure error)
+ false)))
+ (_.test "PATTERN-MATCHING 0"
+ (|> (synthesis.branch/case [special-input
+ special-path])
+ (run "special-path")
+ (case> (#error.Success output)
+ true
+
+ (#error.Failure error)
+ false)))
+ (_.test "PATTERN-MATCHING 1"
+ (|> (synthesis.branch/case [special-input
+ special-pattern-path])
+ (run "special-pattern-path")
+ (case> (#error.Success output)
+ true
+
+ (#error.Failure error)
+ 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/spec/compositor/generation/function.lux b/stdlib/source/spec/compositor/generation/function.lux
new file mode 100644
index 000000000..c9f8f5f56
--- /dev/null
+++ b/stdlib/source/spec/compositor/generation/function.lux
@@ -0,0 +1,92 @@
+(.module:
+ [lux (#- function)
+ ["_" test (#+ Test)]
+ [abstract
+ [monad (#+ do)]]
+ [control
+ [pipe (#+ case>)]]
+ [data
+ ["." maybe]
+ ["." error (#+ Error)]
+ [text
+ format]
+ [collection
+ ["." list ("#@." functor)]]]
+ [math
+ ["r" random (#+ Random) ("#@." monad)]]
+ [tool
+ [compiler
+ [analysis (#+ Arity)]
+ ["." reference (#+ Register)]
+ ["." synthesis (#+ Synthesis)]]]]
+ ["." // #_
+ ["#." case]
+ ["/#" //]])
+
+(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
+ (list.n/range 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)))))
+ )))
generated by cgit v1.2.3 (git 2.25.1) at 2024-12-24 19:19:41 +0000