From 0abd5bd3c0e38e352e9ba38268e04e1c858ab01e Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Thu, 15 Jul 2021 00:45:15 -0400 Subject: Re-named "spec" hierarchy to "specification". --- .../specification/compositor/generation/common.lux | 343 +++++++++++++++++++++ 1 file changed, 343 insertions(+) create mode 100644 stdlib/source/specification/compositor/generation/common.lux (limited to 'stdlib/source/specification/compositor/generation/common.lux') 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 [ (template [ ] + [(_.test + (|> (#synthesis.Extension (list (synthesis.i64 param) + (synthesis.i64 subject))) + (run (..sanitize )) + (case> (#try.Success valueT) + (n.= ( param subject) (:as Nat valueT)) + + (#try.Failure _) + false) + (let [param ])))] + + ["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 + + (_.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 [ ] + [(_.test + (|> (#synthesis.Extension (list (synthesis.i64 subject))) + (run (..sanitize )) + (case> (#try.Success valueT) + ( ( subject) (:as valueT)) + + (#try.Failure _) + false) + (let [subject ])))] + + ["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 [ ] + [(_.test + (|> (#synthesis.Extension (list (synthesis.i64 param) + (synthesis.i64 subject))) + (run (..sanitize )) + (case> (#try.Success valueT) + ( ( param subject) (:as 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 [ ] + [(_.test + (|> (#synthesis.Extension (list (synthesis.f64 param) + (synthesis.f64 subject))) + (run (..sanitize )) + (//case.verify ( param subject))))] + + ["lux f64 +" f.+ f.=] + ["lux f64 -" f.- f.=] + ["lux f64 *" f.* f.=] + ["lux f64 /" f./ f.=] + ["lux f64 %" f.% f.=] + )) + (~~ (template [ ] + [(_.test + (|> (#synthesis.Extension (list (synthesis.f64 param) + (synthesis.f64 subject))) + (run (..sanitize )) + (case> (#try.Success valueV) + (bit\= ( param subject) + (:as Bit valueV)) + + _ + false)))] + + ["lux f64 =" f.=] + ["lux f64 <" f.<] + )) + (~~ (template [ ] + [(_.test + (|> (#synthesis.Extension (list)) + (run (..sanitize )) + (//case.verify )))] + + ["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) + )) -- cgit v1.2.3