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". --- stdlib/source/specification/aedifex/repository.lux | 57 ++++ stdlib/source/specification/compositor.lux | 67 ++++ .../specification/compositor/analysis/type.lux | 63 ++++ stdlib/source/specification/compositor/common.lux | 81 +++++ .../specification/compositor/generation/case.lux | 288 +++++++++++++++++ .../specification/compositor/generation/common.lux | 343 ++++++++++++++++++++ .../compositor/generation/function.lux | 93 ++++++ .../compositor/generation/primitive.lux | 48 +++ .../compositor/generation/reference.lux | 60 ++++ .../compositor/generation/structure.lux | 89 ++++++ stdlib/source/specification/lux/abstract/apply.lux | 73 +++++ stdlib/source/specification/lux/abstract/codec.lux | 27 ++ .../source/specification/lux/abstract/comonad.lux | 61 ++++ stdlib/source/specification/lux/abstract/enum.lux | 27 ++ .../specification/lux/abstract/equivalence.lux | 24 ++ stdlib/source/specification/lux/abstract/fold.lux | 23 ++ .../source/specification/lux/abstract/functor.lux | 62 ++++ .../lux/abstract/functor/contravariant.lux | 31 ++ stdlib/source/specification/lux/abstract/hash.lux | 23 ++ .../source/specification/lux/abstract/interval.lux | 23 ++ stdlib/source/specification/lux/abstract/monad.lux | 57 ++++ .../source/specification/lux/abstract/monoid.lux | 32 ++ stdlib/source/specification/lux/abstract/order.lux | 58 ++++ stdlib/source/specification/lux/world/console.lux | 58 ++++ stdlib/source/specification/lux/world/file.lux | 351 +++++++++++++++++++++ stdlib/source/specification/lux/world/program.lux | 32 ++ stdlib/source/specification/lux/world/shell.lux | 92 ++++++ 27 files changed, 2243 insertions(+) create mode 100644 stdlib/source/specification/aedifex/repository.lux create mode 100644 stdlib/source/specification/compositor.lux create mode 100644 stdlib/source/specification/compositor/analysis/type.lux create mode 100644 stdlib/source/specification/compositor/common.lux create mode 100644 stdlib/source/specification/compositor/generation/case.lux create mode 100644 stdlib/source/specification/compositor/generation/common.lux create mode 100644 stdlib/source/specification/compositor/generation/function.lux create mode 100644 stdlib/source/specification/compositor/generation/primitive.lux create mode 100644 stdlib/source/specification/compositor/generation/reference.lux create mode 100644 stdlib/source/specification/compositor/generation/structure.lux create mode 100644 stdlib/source/specification/lux/abstract/apply.lux create mode 100644 stdlib/source/specification/lux/abstract/codec.lux create mode 100644 stdlib/source/specification/lux/abstract/comonad.lux create mode 100644 stdlib/source/specification/lux/abstract/enum.lux create mode 100644 stdlib/source/specification/lux/abstract/equivalence.lux create mode 100644 stdlib/source/specification/lux/abstract/fold.lux create mode 100644 stdlib/source/specification/lux/abstract/functor.lux create mode 100644 stdlib/source/specification/lux/abstract/functor/contravariant.lux create mode 100644 stdlib/source/specification/lux/abstract/hash.lux create mode 100644 stdlib/source/specification/lux/abstract/interval.lux create mode 100644 stdlib/source/specification/lux/abstract/monad.lux create mode 100644 stdlib/source/specification/lux/abstract/monoid.lux create mode 100644 stdlib/source/specification/lux/abstract/order.lux create mode 100644 stdlib/source/specification/lux/world/console.lux create mode 100644 stdlib/source/specification/lux/world/file.lux create mode 100644 stdlib/source/specification/lux/world/program.lux create mode 100644 stdlib/source/specification/lux/world/shell.lux (limited to 'stdlib/source/specification') diff --git a/stdlib/source/specification/aedifex/repository.lux b/stdlib/source/specification/aedifex/repository.lux new file mode 100644 index 000000000..de9a05fde --- /dev/null +++ b/stdlib/source/specification/aedifex/repository.lux @@ -0,0 +1,57 @@ +(.module: + [library + [lux #* + ["_" test (#+ Test)] + [abstract + [monad (#+ do)]] + [control + ["." try (#+ Try)] + [concurrency + ["." promise (#+ Promise)]]] + [data + ["." binary + ["_#" \\test]]] + [math + ["." random]]]] + [\\program + ["." / + ["#." remote] + ["/#" // #_ + ["#." artifact (#+ Artifact) + ["#/." extension]]]]] + [\\test + ["_." // #_ + ["#." artifact]]]) + +(def: #export (spec valid_artifact invalid_artifact subject) + (-> Artifact Artifact (/.Repository Promise) Test) + (do random.monad + [expected (_binary.random 100)] + (wrap ($_ _.and' + (do promise.monad + [#let [good_uri (/remote.uri (get@ #//artifact.version valid_artifact) valid_artifact //artifact/extension.lux_library)] + good_upload! (\ subject upload good_uri expected) + good_download! (\ subject download good_uri) + + #let [bad_uri (/remote.uri (get@ #//artifact.version invalid_artifact) invalid_artifact //artifact/extension.lux_library)] + bad_upload! (\ subject upload bad_uri expected) + bad_download! (\ subject download bad_uri)] + (_.cover' [/.Repository] + (let [successfull_flow! + (case [good_upload! good_download!] + [(#try.Success _) (#try.Success actual)] + (\ binary.equivalence = expected actual) + + _ + false) + + failed_flow! + (case [bad_upload! bad_download!] + [(#try.Failure _) (#try.Failure _)] + true + + _ + false)] + (and successfull_flow! + failed_flow!)))) + )))) diff --git a/stdlib/source/specification/compositor.lux b/stdlib/source/specification/compositor.lux new file mode 100644 index 000000000..08a294282 --- /dev/null +++ b/stdlib/source/specification/compositor.lux @@ -0,0 +1,67 @@ +(.module: + [lux #* + ["_" test (#+ Test)] + [abstract + [monad (#+ do)]] + [control + ["." io (#+ IO)] + ["." try]] + [math + ["r" random]] + [tool + [compiler + ["." analysis] + ["." directive] + [phase + [macro (#+ Expander)] + [generation (#+ Bundle)]] + [default + [platform (#+ Platform)]]]]] + ["." / #_ + ["#." common (#+ Runner Definer)] + ["#./" analysis #_ + ["#." type]] + ["#./" generation #_ + ["#." primitive] + ["#." structure] + ["#." reference] + ["#." case] + ["#." function] + ["#." common]]]) + +(def: (test runner definer state expander) + (-> Runner Definer analysis.State+ Expander Test) + ($_ _.and + (/analysis/type.spec expander state) + (/generation/primitive.spec runner) + (/generation/structure.spec runner) + (/generation/reference.spec runner definer) + (/generation/case.spec runner) + (/generation/function.spec runner) + (/generation/common.spec runner) + )) + +(def: #export (spec platform bundle expander program) + (All [anchor expression directive] + (-> (IO (Platform IO anchor expression directive)) + (Bundle anchor expression directive) + Expander + (-> expression directive) + Test)) + (do r.monad + [_ (wrap []) + #let [?state,runner,definer (<| io.run + (do io.monad + [platform platform]) + (/common.executors platform + bundle + expander + program))]] + (case ?state,runner,definer + (#try.Success [[directive-bundle directive-state] runner definer]) + (..test runner definer + (get@ [#directive.analysis #directive.state] directive-state) + expander) + + (#try.Failure error) + (_.fail error)))) diff --git a/stdlib/source/specification/compositor/analysis/type.lux b/stdlib/source/specification/compositor/analysis/type.lux new file mode 100644 index 000000000..7cbd5884b --- /dev/null +++ b/stdlib/source/specification/compositor/analysis/type.lux @@ -0,0 +1,63 @@ +(.module: + [lux #* + ["_" test (#+ Test)] + [abstract + [monad (#+ do)]] + [control + [pipe (#+ case>)] + ["." io] + ["." try]] + [math + ["r" random (#+ Random)]] + [macro + ["." code]] + [tool + [compiler + [analysis (#+ State+)] + ["." phase + [macro (#+ Expander)] + ["." analysis + ["#/." scope] + ["#/." type]]]]]]) + +(def: (check-success+ expander state extension params output-type) + (-> Expander State+ Text (List Code) Type Bit) + (|> (analysis/scope.with-scope "" + (analysis/type.with-type output-type + (analysis.phase expander (` ((~ (code.text extension)) (~+ params)))))) + (phase.run state) + (case> (#try.Success _) + true + + (#try.Failure _) + false))) + +(def: check + (Random [Code Type Code]) + (`` ($_ r.either + (~~ (template [ ] + [(do r.monad + [value ] + (wrap [(` ) + + ( value)]))] + + [r.bit (0 #0 "#Bit" (0 #0)) code.bit] + [r.nat (0 #0 "#I64" (0 #1 (0 #0 "#Nat" (0 #0)) (0 #0))) code.nat] + [r.int (0 #0 "#I64" (0 #1 (0 #0 "#Int" (0 #0)) (0 #0))) code.int] + [r.rev (0 #0 "#I64" (0 #1 (0 #0 "#Rev" (0 #0)) (0 #0))) code.rev] + [r.safe-frac (0 #0 "#Frac" (0 #0)) code.frac] + [(r.ascii/upper-alpha 5) (0 #0 "#Text" (0 #0)) code.text] + ))))) + +(def: #export (spec expander state) + (-> Expander State+ Test) + (do r.monad + [[typeC exprT exprC] ..check + [other-typeC other-exprT other-exprC] ..check] + ($_ _.and + (_.test "lux check" + (check-success+ expander state "lux check" (list typeC exprC) exprT)) + (_.test "lux coerce" + (check-success+ expander state "lux coerce" (list typeC other-exprC) exprT)) + ))) diff --git a/stdlib/source/specification/compositor/common.lux b/stdlib/source/specification/compositor/common.lux new file mode 100644 index 000000000..ed3b53f30 --- /dev/null +++ b/stdlib/source/specification/compositor/common.lux @@ -0,0 +1,81 @@ +(.module: + [lux #* + [abstract + [monad (#+ do)]] + [control + ["." io (#+ IO)] + ["." try (#+ Try)]] + [tool + [compiler + ["." reference] + ["." analysis] + ["." synthesis (#+ Synthesis)] + ["." directive] + ["." phase + ["." macro (#+ Expander)] + ["." generation (#+ Operation)] + [extension (#+ Extender) + ["." bundle]]] + [default + ["." platform (#+ Platform)]]]]]) + +(type: #export Runner + (-> Text Synthesis (Try Any))) + +(type: #export Definer + (-> Name Synthesis (Try Any))) + +(type: #export (Instancer what) + (All [anchor expression directive] + (-> (Platform IO anchor expression directive) + (generation.State+ anchor expression directive) + what))) + +(def: (runner (^slots [#platform.runtime #platform.phase #platform.host]) state) + (Instancer Runner) + (function (_ evaluation-name expressionS) + (do try.monad + [expressionG (<| (phase.run state) + generation.with-buffer + (do phase.monad + [_ runtime] + (phase expressionS)))] + (\ host evaluate! evaluation-name expressionG)))) + +(def: (definer (^slots [#platform.runtime #platform.phase #platform.host]) + state) + (Instancer Definer) + (function (_ lux-name expressionS) + (do try.monad + [definitionG (<| (phase.run state) + generation.with-buffer + (do phase.monad + [_ runtime + expressionG (phase expressionS) + [host-name host-value host-directive] (generation.define! lux-name expressionG) + _ (generation.learn lux-name host-name)] + (phase (synthesis.constant lux-name))))] + (\ host evaluate! "definer" definitionG)))) + +(def: #export (executors target expander platform + analysis-bundle generation-bundle directive-bundle + program extender) + (All [anchor expression directive] + (-> Text Expander (Platform IO anchor expression directive) + analysis.Bundle + (generation.Bundle anchor expression directive) + (directive.Bundle anchor expression directive) + (-> expression directive) Extender + (IO (Try [(directive.State+ anchor expression directive) + Runner + Definer])))) + (do io.monad + [?state (platform.initialize target expander analysis-bundle platform generation-bundle directive-bundle program extender)] + (wrap (do try.monad + [[directive-bundle directive-state] ?state + #let [generation-state (get@ [#directive.generation + #directive.state] + directive-state)]] + (wrap [[directive-bundle directive-state] + (..runner platform generation-state) + (..definer platform generation-state)]))))) 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 [ ] + [(do r.monad + [value ] + (wrap [( value) + ( 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 ) + (<| 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 [ (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) + )) 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 [ ] + [(do r.monad + [expected ] + (_.test (%.name (name-of )) + (|> (run ( expected)) + (case> (#try.Success actual) + ( 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) + )) diff --git a/stdlib/source/specification/lux/abstract/apply.lux b/stdlib/source/specification/lux/abstract/apply.lux new file mode 100644 index 000000000..691e8c01c --- /dev/null +++ b/stdlib/source/specification/lux/abstract/apply.lux @@ -0,0 +1,73 @@ +(.module: + [library + [lux #* + ["_" test (#+ Test)] + [abstract + [monad (#+ do)]] + [control + ["." function]] + [math + ["." random] + [number + ["n" nat]]]]] + [\\library + ["." / (#+ Apply)]] + [// + [functor (#+ Injection Comparison)]]) + +(def: (identity injection comparison (^open "\.")) + (All [f] (-> (Injection f) (Comparison f) (Apply f) Test)) + (do {! random.monad} + [sample (\ ! map injection random.nat)] + (_.test "Identity." + ((comparison n.=) + (\apply (injection function.identity) sample) + sample)))) + +(def: (homomorphism injection comparison (^open "\.")) + (All [f] (-> (Injection f) (Comparison f) (Apply f) Test)) + (do {! random.monad} + [sample random.nat + increase (\ ! map n.+ random.nat)] + (_.test "Homomorphism." + ((comparison n.=) + (\apply (injection increase) (injection sample)) + (injection (increase sample)))))) + +(def: (interchange injection comparison (^open "\.")) + (All [f] (-> (Injection f) (Comparison f) (Apply f) Test)) + (do {! random.monad} + [sample random.nat + increase (\ ! map n.+ random.nat)] + (_.test "Interchange." + ((comparison n.=) + (\apply (injection increase) (injection sample)) + (\apply (injection (function (_ f) (f sample))) (injection increase)))))) + +(def: (composition injection comparison (^open "\.")) + (All [f] (-> (Injection f) (Comparison f) (Apply f) Test)) + (do {! random.monad} + [sample random.nat + increase (\ ! map n.+ random.nat) + decrease (\ ! map n.- random.nat)] + (_.test "Composition." + ((comparison n.=) + (_$ \apply + (injection function.compose) + (injection increase) + (injection decrease) + (injection sample)) + ($_ \apply + (injection increase) + (injection decrease) + (injection sample)))))) + +(def: #export (spec injection comparison apply) + (All [f] (-> (Injection f) (Comparison f) (Apply f) Test)) + (_.for [/.Apply] + ($_ _.and + (..identity injection comparison apply) + (..homomorphism injection comparison apply) + (..interchange injection comparison apply) + (..composition injection comparison apply) + ))) diff --git a/stdlib/source/specification/lux/abstract/codec.lux b/stdlib/source/specification/lux/abstract/codec.lux new file mode 100644 index 000000000..f58f6ce91 --- /dev/null +++ b/stdlib/source/specification/lux/abstract/codec.lux @@ -0,0 +1,27 @@ +(.module: + [library + [lux #* + ["_" test (#+ Test)] + [abstract + [monad (#+ do)]] + [control + ["." try]] + [math + ["." random (#+ Random)]]]] + [\\library + ["." / + [// + [equivalence (#+ Equivalence)]]]]) + +(def: #export (spec (^open "@//.") (^open "@//.") generator) + (All [m a] (-> (Equivalence a) (/.Codec m a) (Random a) Test)) + (do random.monad + [expected generator] + (_.for [/.Codec] + (_.test "Isomorphism." + (case (|> expected @//encode @//decode) + (#try.Success actual) + (@//= expected actual) + + (#try.Failure _) + false))))) diff --git a/stdlib/source/specification/lux/abstract/comonad.lux b/stdlib/source/specification/lux/abstract/comonad.lux new file mode 100644 index 000000000..85d00b8f2 --- /dev/null +++ b/stdlib/source/specification/lux/abstract/comonad.lux @@ -0,0 +1,61 @@ +(.module: + [library + [lux #* + ["_" test (#+ Test)] + [abstract + [monad (#+ do)]] + [math + ["." random] + [number + ["n" nat]]]]] + [\\library + ["." / (#+ CoMonad)]] + [// + [functor (#+ Injection Comparison)]]) + +(def: (left-identity injection (^open "_//.")) + (All [f] (-> (Injection f) (CoMonad f) Test)) + (do {! random.monad} + [sample random.nat + morphism (\ ! map (function (_ diff) + (|>> _//unwrap (n.+ diff))) + random.nat) + #let [start (injection sample)]] + (_.test "Left identity." + (n.= (morphism start) + (|> start _//split (_//map morphism) _//unwrap))))) + +(def: (right-identity injection comparison (^open "_//.")) + (All [f] (-> (Injection f) (Comparison f) (CoMonad f) Test)) + (do random.monad + [sample random.nat + #let [start (injection sample) + == (comparison n.=)]] + (_.test "Right identity." + (== start + (|> start _//split (_//map _//unwrap)))))) + +(def: (associativity injection comparison (^open "_//.")) + (All [f] (-> (Injection f) (Comparison f) (CoMonad f) Test)) + (do {! random.monad} + [sample random.nat + increase (\ ! map (function (_ diff) + (|>> _//unwrap (n.+ diff))) + random.nat) + decrease (\ ! map (function (_ diff) + (|>> _//unwrap(n.- diff))) + random.nat) + #let [start (injection sample) + == (comparison n.=)]] + (_.test "Associativity." + (== (|> start _//split (_//map (|>> _//split (_//map increase) decrease))) + (|> start _//split (_//map increase) _//split (_//map decrease)))))) + +(def: #export (spec injection comparison subject) + (All [f] (-> (Injection f) (Comparison f) (CoMonad f) Test)) + (<| (_.for [/.CoMonad]) + ($_ _.and + (..left-identity injection subject) + (..right-identity injection comparison subject) + (..associativity injection comparison subject) + ))) diff --git a/stdlib/source/specification/lux/abstract/enum.lux b/stdlib/source/specification/lux/abstract/enum.lux new file mode 100644 index 000000000..ddb2a80f1 --- /dev/null +++ b/stdlib/source/specification/lux/abstract/enum.lux @@ -0,0 +1,27 @@ +(.module: + [library + [lux #* + ["_" test (#+ Test)] + [abstract + [monad (#+ do)]] + [math + ["." random (#+ Random)]]]] + [\\library + ["." /]]) + +(def: #export (spec (^open "\.") gen-sample) + (All [a] (-> (/.Enum a) (Random a) Test)) + (do random.monad + [sample gen-sample] + (<| (_.for [/.Enum]) + ($_ _.and + (_.test "Successor and predecessor are inverse functions." + (and (\= (|> sample \succ \pred) + sample) + (\= (|> sample \pred \succ) + sample) + (not (\= (\succ sample) + sample)) + (not (\= (\pred sample) + sample)))) + )))) diff --git a/stdlib/source/specification/lux/abstract/equivalence.lux b/stdlib/source/specification/lux/abstract/equivalence.lux new file mode 100644 index 000000000..4d6d0900a --- /dev/null +++ b/stdlib/source/specification/lux/abstract/equivalence.lux @@ -0,0 +1,24 @@ +(.module: + [library + [lux #* + ["_" test (#+ Test)] + [abstract + [monad (#+ do)]] + [math + ["." random (#+ Random)]]]] + [\\library + ["." / (#+ Equivalence)]]) + +(def: #export (spec (^open "_//.") random) + (All [a] (-> (Equivalence a) (Random a) Test)) + (do random.monad + [left random + right random] + (<| (_.for [/.Equivalence]) + ($_ _.and + (_.test "Reflexivity." + (_//= left left)) + (_.test "Symmetry." + (if (_//= left right) + (_//= right left) + (not (_//= right left)))))))) diff --git a/stdlib/source/specification/lux/abstract/fold.lux b/stdlib/source/specification/lux/abstract/fold.lux new file mode 100644 index 000000000..2b4a7617f --- /dev/null +++ b/stdlib/source/specification/lux/abstract/fold.lux @@ -0,0 +1,23 @@ +(.module: + [library + [lux #* + ["_" test (#+ Test)] + [abstract + [monad (#+ do)]] + [math + ["." random] + [number + ["n" nat]]]]] + [// + [functor (#+ Injection Comparison)]] + [\\library + ["." /]]) + +(def: #export (spec injection comparison (^open "@//.")) + (All [f] (-> (Injection f) (Comparison f) (/.Fold f) Test)) + (do random.monad + [subject random.nat + parameter random.nat] + (_.cover [/.Fold] + (n.= (@//fold n.+ parameter (injection subject)) + (n.+ parameter subject))))) diff --git a/stdlib/source/specification/lux/abstract/functor.lux b/stdlib/source/specification/lux/abstract/functor.lux new file mode 100644 index 000000000..cfa6cc2ff --- /dev/null +++ b/stdlib/source/specification/lux/abstract/functor.lux @@ -0,0 +1,62 @@ +(.module: + [library + [lux #* + ["_" test (#+ Test)] + [abstract + [equivalence (#+ Equivalence)] + [monad (#+ do)]] + [control + ["." function]] + [math + ["." random] + [number + ["n" nat]]]]] + [\\library + ["." / (#+ Functor)]]) + +(type: #export (Injection f) + (All [a] (-> a (f a)))) + +(type: #export (Comparison f) + (All [a] + (-> (Equivalence a) + (Equivalence (f a))))) + +(def: (identity injection comparison (^open "@//.")) + (All [f] (-> (Injection f) (Comparison f) (Functor f) Test)) + (do {! random.monad} + [sample (\ ! map injection random.nat)] + (_.test "Identity." + ((comparison n.=) + (@//map function.identity sample) + sample)))) + +(def: (homomorphism injection comparison (^open "@//.")) + (All [f] (-> (Injection f) (Comparison f) (Functor f) Test)) + (do {! random.monad} + [sample random.nat + increase (\ ! map n.+ random.nat)] + (_.test "Homomorphism." + ((comparison n.=) + (@//map increase (injection sample)) + (injection (increase sample)))))) + +(def: (composition injection comparison (^open "@//.")) + (All [f] (-> (Injection f) (Comparison f) (Functor f) Test)) + (do {! random.monad} + [sample (\ ! map injection random.nat) + increase (\ ! map n.+ random.nat) + decrease (\ ! map n.- random.nat)] + (_.test "Composition." + ((comparison n.=) + (|> sample (@//map increase) (@//map decrease)) + (|> sample (@//map (|>> increase decrease))))))) + +(def: #export (spec injection comparison functor) + (All [f] (-> (Injection f) (Comparison f) (Functor f) Test)) + (<| (_.for [/.Functor]) + ($_ _.and + (..identity injection comparison functor) + (..homomorphism injection comparison functor) + (..composition injection comparison functor) + ))) diff --git a/stdlib/source/specification/lux/abstract/functor/contravariant.lux b/stdlib/source/specification/lux/abstract/functor/contravariant.lux new file mode 100644 index 000000000..cba839e94 --- /dev/null +++ b/stdlib/source/specification/lux/abstract/functor/contravariant.lux @@ -0,0 +1,31 @@ +(.module: + [library + [lux #* + ["_" test (#+ Test)] + [abstract + [equivalence (#+ Equivalence)] + [monad (#+ do)]] + [control + ["." function]] + [math + ["." random] + [number + ["n" nat]]]]] + [\\library + ["." / (#+ Functor)]]) + +(def: (identity equivalence value (^open "@//.")) + (All [f a] (-> (Equivalence (f a)) (f a) (Functor f) Test)) + (_.test "Law of identity." + (equivalence + (@//map function.identity value) + value))) + +(def: #export (spec equivalence value functor) + (All [f a] (-> (Equivalence (f a)) (f a) (Functor f) Test)) + (do random.monad + [sample random.nat] + (<| (_.for [/.Functor]) + ($_ _.and + (..identity equivalence value functor) + )))) diff --git a/stdlib/source/specification/lux/abstract/hash.lux b/stdlib/source/specification/lux/abstract/hash.lux new file mode 100644 index 000000000..4722a48a0 --- /dev/null +++ b/stdlib/source/specification/lux/abstract/hash.lux @@ -0,0 +1,23 @@ +(.module: + [library + [lux #* + ["_" test (#+ Test)] + [abstract + [monad (#+ do)]] + [data + ["." bit ("#\." equivalence)]] + [math + ["." random (#+ Random)] + [number + ["n" nat]]]]] + [\\library + ["." /]]) + +(def: #export (spec (^open "\.") random) + (All [a] (-> (/.Hash a) (Random a) Test)) + (do random.monad + [parameter random + subject random] + (_.cover [/.Hash] + (bit\= (\= parameter subject) + (n.= (\hash parameter) (\hash subject)))))) diff --git a/stdlib/source/specification/lux/abstract/interval.lux b/stdlib/source/specification/lux/abstract/interval.lux new file mode 100644 index 000000000..5b74bc34d --- /dev/null +++ b/stdlib/source/specification/lux/abstract/interval.lux @@ -0,0 +1,23 @@ +(.module: + [library + [lux #* + ["_" test (#+ Test)] + [abstract + [monad (#+ do)] + ["." order]] + [math + ["." random (#+ Random)]]]] + [\\library + ["." /]]) + +(def: #export (spec (^open "@//.") gen-sample) + (All [a] (-> (/.Interval a) (Random a) Test)) + (<| (_.for [/.Interval]) + (do random.monad + [sample gen-sample] + ($_ _.and + (_.test "No value is bigger than the top." + (@//< @//top sample)) + (_.test "No value is smaller than the bottom." + (order.> @//&order @//bottom sample)) + )))) diff --git a/stdlib/source/specification/lux/abstract/monad.lux b/stdlib/source/specification/lux/abstract/monad.lux new file mode 100644 index 000000000..869eb24c7 --- /dev/null +++ b/stdlib/source/specification/lux/abstract/monad.lux @@ -0,0 +1,57 @@ +(.module: + [library + [lux #* + ["_" test (#+ Test)] + [math + ["." random] + [number + ["n" nat]]]]] + [\\library + ["." / (#+ do)]] + [// + [functor (#+ Injection Comparison)]]) + +(def: (left-identity injection comparison (^open "_//.")) + (All [f] (-> (Injection f) (Comparison f) (/.Monad f) Test)) + (do {! random.monad} + [sample random.nat + morphism (\ ! map (function (_ diff) + (|>> (n.+ diff) _//wrap)) + random.nat)] + (_.test "Left identity." + ((comparison n.=) + (|> (injection sample) (_//map morphism) _//join) + (morphism sample))))) + +(def: (right-identity injection comparison (^open "_//.")) + (All [f] (-> (Injection f) (Comparison f) (/.Monad f) Test)) + (do random.monad + [sample random.nat] + (_.test "Right identity." + ((comparison n.=) + (|> (injection sample) (_//map _//wrap) _//join) + (injection sample))))) + +(def: (associativity injection comparison (^open "_//.")) + (All [f] (-> (Injection f) (Comparison f) (/.Monad f) Test)) + (do {! random.monad} + [sample random.nat + increase (\ ! map (function (_ diff) + (|>> (n.+ diff) _//wrap)) + random.nat) + decrease (\ ! map (function (_ diff) + (|>> (n.- diff) _//wrap)) + random.nat)] + (_.test "Associativity." + ((comparison n.=) + (|> (injection sample) (_//map increase) _//join (_//map decrease) _//join) + (|> (injection sample) (_//map (|>> increase (_//map decrease) _//join)) _//join))))) + +(def: #export (spec injection comparison monad) + (All [f] (-> (Injection f) (Comparison f) (/.Monad f) Test)) + (<| (_.for [/.Monad]) + ($_ _.and + (..left-identity injection comparison monad) + (..right-identity injection comparison monad) + (..associativity injection comparison monad) + ))) diff --git a/stdlib/source/specification/lux/abstract/monoid.lux b/stdlib/source/specification/lux/abstract/monoid.lux new file mode 100644 index 000000000..f8626fe74 --- /dev/null +++ b/stdlib/source/specification/lux/abstract/monoid.lux @@ -0,0 +1,32 @@ +(.module: + [library + [lux #* + ["_" test (#+ Test)] + [abstract + [monad (#+ do)]] + [math + ["." random (#+ Random)]]]] + [\\library + ["." / + [// + [equivalence (#+ Equivalence)]]]]) + +(def: #export (spec (^open "\.") (^open "\.") gen-sample) + (All [a] (-> (Equivalence a) (/.Monoid a) (Random a) Test)) + (do random.monad + [sample gen-sample + left gen-sample + mid gen-sample + right gen-sample] + (<| (_.for [/.Monoid]) + ($_ _.and + (_.test "Left identity." + (\= sample + (\compose \identity sample))) + (_.test "Right identity." + (\= sample + (\compose sample \identity))) + (_.test "Associativity." + (\= (\compose left (\compose mid right)) + (\compose (\compose left mid) right))) + )))) diff --git a/stdlib/source/specification/lux/abstract/order.lux b/stdlib/source/specification/lux/abstract/order.lux new file mode 100644 index 000000000..61fc22611 --- /dev/null +++ b/stdlib/source/specification/lux/abstract/order.lux @@ -0,0 +1,58 @@ +(.module: + [library + [lux #* + ["_" test (#+ Test)] + [abstract + [monad (#+ do)]] + [math + ["." random (#+ Random)]]]] + [\\library + ["." /]]) + +(def: #export (spec (^open "@//.") generator) + (All [a] (-> (/.Order a) (Random a) Test)) + (<| (_.for [/.Order]) + ($_ _.and + (do random.monad + [parameter generator + subject generator] + (_.test "Values are either ordered, or they are equal. All options are mutually exclusive." + (cond (@//< parameter subject) + (not (or (@//< subject parameter) + (@//= parameter subject))) + + (@//< subject parameter) + (not (@//= parameter subject)) + + ## else + (@//= parameter subject)))) + (do random.monad + [parameter generator + subject (random.filter (|>> (@//= parameter) not) + generator) + extra (random.filter (function (_ value) + (not (or (@//= parameter value) + (@//= subject value)))) + generator)] + (_.test "Transitive property." + (if (@//< parameter subject) + (let [greater? (and (@//< subject extra) + (@//< parameter extra)) + lesser? (and (@//< extra parameter) + (@//< extra subject)) + in-between? (and (@//< parameter extra) + (@//< extra subject))] + (or greater? + lesser? + in-between?)) + ## (@//< subject parameter) + (let [greater? (and (@//< extra subject) + (@//< extra parameter)) + lesser? (and (@//< parameter extra) + (@//< subject extra)) + in-between? (and (@//< subject extra) + (@//< extra parameter))] + (or greater? + lesser? + in-between?))))) + ))) diff --git a/stdlib/source/specification/lux/world/console.lux b/stdlib/source/specification/lux/world/console.lux new file mode 100644 index 000000000..f454b61c9 --- /dev/null +++ b/stdlib/source/specification/lux/world/console.lux @@ -0,0 +1,58 @@ +(.module: + [library + [lux #* + ["_" test (#+ Test)] + [abstract + [monad (#+ do)]] + [control + [io (#+ IO)] + ["." try] + [concurrency + ["." promise (#+ Promise)]]] + [data + ["." text + ["%" format (#+ format)]]] + [math + ["." random]]]] + [\\library + ["." /]]) + +(def: #export (spec console) + (-> (IO (/.Console Promise)) Test) + (do random.monad + [message (random.ascii/alpha 10)] + (wrap (do promise.monad + [console (promise.future console) + ?write (\ console write (format message text.new_line)) + ?read (\ console read []) + ?read_line (\ console read_line []) + ?close/good (\ console close []) + ?close/bad (\ console close []) + + #let [can_write! + (case ?write + (#try.Success _) + true + + _ + false) + + can_read! + (case [?read ?read_line] + [(#try.Success _) (#try.Success _)] + true + + _ + false) + + can_close! + (case [?close/good ?close/bad] + [(#try.Success _) (#try.Failure _)] + true + + _ + false)]] + (_.cover' [/.Console] + (and can_write! + can_read! + can_close!)))))) diff --git a/stdlib/source/specification/lux/world/file.lux b/stdlib/source/specification/lux/world/file.lux new file mode 100644 index 000000000..7bdefb173 --- /dev/null +++ b/stdlib/source/specification/lux/world/file.lux @@ -0,0 +1,351 @@ +(.module: + [library + [lux #* + ["_" test (#+ Test)] + [abstract + [monad (#+ do)] + ["." predicate]] + [control + [pipe (#+ case>)] + [io (#+ IO)] + ["." try ("#\." functor)] + ["." exception] + [concurrency + ["." promise (#+ Promise)]]] + [data + ["." maybe ("#\." functor)] + ["." text ("#\." equivalence) + ["%" format (#+ format)] + [encoding + ["." utf8 ("#\." codec)]]] + ["." binary (#+ Binary) ("#\." equivalence monoid) + ["$#" \\test]] + [collection + ["." list]]] + [math + ["." random] + [number + ["n" nat]]] + [time + ["." instant (#+ Instant) ("#\." equivalence)]]]] + [\\library + ["." /]]) + +(def: (for_path fs) + (-> (IO (/.System Promise)) Test) + (<| (_.for [/.Path]) + (do {! random.monad} + [parent (random.ascii/numeric 2) + child (random.ascii/numeric 2)]) + wrap + (do promise.monad + [fs (promise.future fs)] + ($_ _.and' + (_.cover' [/.un_nest] + (and (|> (/.un_nest fs parent) + (case> (#.Some _) + false + + #.None + true)) + (|> (/.un_nest fs child) + (case> (#.Some _) + false + + #.None + true)))) + (_.cover' [/.nest] + (|> (/.nest fs parent child) + (/.un_nest fs) + (case> (#.Some [parent' child']) + (and (text\= parent parent') + (text\= child child')) + + #.None + false))) + (_.cover' [/.parent] + (|> (/.nest fs parent child) + (/.parent fs) + (maybe\map (text\= parent)) + (maybe.default false))) + (_.cover' [/.name] + (|> (/.nest fs parent child) + (/.name fs) + (text\= child))) + )))) + +(def: (directory?&make_directory fs parent) + (-> (/.System Promise) /.Path (Promise Bit)) + (do promise.monad + [directory_pre! (\ fs directory? parent) + made? (\ fs make_directory parent) + directory_post! (\ fs directory? parent)] + (wrap (and (not directory_pre!) + (case made? + (#try.Success _) true + (#try.Failure _) false) + directory_post!)))) + +(def: (file?&write fs content path) + (-> (/.System Promise) Binary /.Path (Promise Bit)) + (do promise.monad + [file_pre! (\ fs file? path) + made? (\ fs write content path) + file_post! (\ fs file? path)] + (wrap (and (not file_pre!) + (case made? + (#try.Success _) true + (#try.Failure _) false) + file_post!)))) + +(def: (file_size&read&append fs expected_file_size content appendix path) + (-> (/.System Promise) Nat Binary Binary /.Path (Promise Bit)) + (do promise.monad + [pre_file_size (\ fs file_size path) + pre_content (\ fs read path) + appended? (\ fs append appendix path) + post_file_size (\ fs file_size path) + post_content (\ fs read path)] + (wrap (<| (try.default false) + (do {! try.monad} + [pre_file_size! + (\ ! map (n.= expected_file_size) pre_file_size) + + pre_content! + (\ ! map (binary\= content) pre_content) + + _ appended? + + post_file_size! + (\ ! map (n.= (n.* 2 expected_file_size)) post_file_size) + + post_content! + (\ ! map (binary\= (binary\compose content appendix)) post_content)] + (wrap (and pre_file_size! + pre_content! + post_file_size! + post_content!))))))) + +(def: (modified?&last_modified fs expected_time path) + (-> (/.System Promise) Instant /.Path (Promise Bit)) + (do promise.monad + [modified? (\ fs modify expected_time path) + last_modified (\ fs last_modified path)] + (wrap (<| (try.default false) + (do {! try.monad} + [_ modified?] + (\ ! map (instant\= expected_time) last_modified)))))) + +(def: (directory_files&sub_directories fs parent sub_dir child) + (-> (/.System Promise) /.Path /.Path /.Path (Promise Bit)) + (let [sub_dir (/.nest fs parent sub_dir) + child (/.nest fs parent child)] + (do promise.monad + [made_sub? (\ fs make_directory sub_dir) + directory_files (\ fs directory_files parent) + sub_directories (\ fs sub_directories parent) + #let [(^open "list\.") (list.equivalence text.equivalence)]] + (wrap (<| (try.default false) + (do try.monad + [_ made_sub?] + (wrap (and (|> directory_files + (try\map (list\= (list child))) + (try.default false)) + (|> sub_directories + (try\map (list\= (list sub_dir))) + (try.default false)))))))))) + +(def: (move&delete fs parent child alternate_child) + (-> (/.System Promise) /.Path Text Text (Promise Bit)) + (let [origin (/.nest fs parent child) + destination (/.nest fs parent alternate_child)] + (do {! promise.monad} + [moved? (\ fs move destination origin) + lost? (|> origin + (\ fs file?) + (\ ! map not)) + found? (\ fs file? destination) + deleted? (\ fs delete destination)] + (wrap (<| (try.default false) + (do try.monad + [_ moved? + _ deleted?] + (wrap (and lost? + found?)))))))) + +(def: (for_system fs) + (-> (IO (/.System Promise)) Test) + (<| (do {! random.monad} + [parent (random.ascii/numeric 2) + child (random.ascii/numeric 2) + sub_dir (random.filter (|>> (text\= child) not) + (random.ascii/numeric 2)) + alternate_child (random.filter (predicate.intersect + (|>> (text\= child) not) + (|>> (text\= sub_dir) not)) + (random.ascii/numeric 2)) + expected_file_size (\ ! map (|>> (n.% 10) inc) random.nat) + content ($binary.random expected_file_size) + appendix ($binary.random expected_file_size) + expected_time random.instant]) + wrap + (do {! promise.monad} + [fs (promise.future fs) + #let [path (/.nest fs parent child)] + + directory?&make_directory + (..directory?&make_directory fs parent) + + file?&write + (..file?&write fs content path) + + file_size&read&append + (..file_size&read&append fs expected_file_size content appendix path) + + modified?&last_modified + (..modified?&last_modified fs expected_time path) + + can_execute? + (|> path + (\ fs can_execute?) + (\ ! map (|>> (try.default true) not))) + + directory_files&sub_directories + (..directory_files&sub_directories fs parent sub_dir child) + + move&delete + (..move&delete fs parent child alternate_child)]) + (_.cover' [/.System] + (and directory?&make_directory + file?&write + file_size&read&append + modified?&last_modified + can_execute? + directory_files&sub_directories + move&delete)))) + +(def: (make_directories&cannot_make_directory fs) + (-> (IO (/.System Promise)) Test) + (<| (do {! random.monad} + [dir/0 (random.ascii/numeric 2) + dir/1 (random.ascii/numeric 2) + dir/2 (random.ascii/numeric 2)]) + wrap + (do {! promise.monad} + [fs (promise.future fs) + #let [dir/1 (/.nest fs dir/0 dir/1) + dir/2 (/.nest fs dir/1 dir/2)] + pre_dir/0 (\ fs directory? dir/0) + pre_dir/1 (\ fs directory? dir/1) + pre_dir/2 (\ fs directory? dir/2) + made? (/.make_directories ! fs dir/2) + post_dir/0 (\ fs directory? dir/0) + post_dir/1 (\ fs directory? dir/1) + post_dir/2 (\ fs directory? dir/2) + + cannot_make_directory!/0 (/.make_directories ! fs "") + cannot_make_directory!/1 (/.make_directories ! fs (\ fs separator))]) + ($_ _.and' + (_.cover' [/.make_directories] + (and (not pre_dir/0) + (not pre_dir/1) + (not pre_dir/2) + (case made? + (#try.Success _) true + (#try.Failure _) false) + post_dir/0 + post_dir/1 + post_dir/2)) + (_.cover' [/.cannot_make_directory] + (and (case cannot_make_directory!/0 + (#try.Success _) + false + + (#try.Failure error) + (exception.match? /.cannot_make_directory error)) + (case cannot_make_directory!/1 + (#try.Success _) + false + + (#try.Failure error) + (exception.match? /.cannot_make_directory error)))) + ))) + +(def: (make_file&cannot_make_file fs) + (-> (IO (/.System Promise)) Test) + (<| (do {! random.monad} + [file/0 (random.ascii/numeric 3)]) + wrap + (do {! promise.monad} + [fs (promise.future fs) + make_file!/0 (/.make_file ! fs (utf8\encode file/0) file/0) + make_file!/1 (/.make_file ! fs (utf8\encode file/0) file/0)]) + ($_ _.and' + (_.cover' [/.make_file] + (case make_file!/0 + (#try.Success _) true + (#try.Failure error) false)) + (_.cover' [/.cannot_make_file] + (case make_file!/1 + (#try.Success _) + false + + (#try.Failure error) + (exception.match? /.cannot_make_file error))) + ))) + +(def: (for_utilities fs) + (-> (IO (/.System Promise)) Test) + ($_ _.and + (..make_directories&cannot_make_directory fs) + (..make_file&cannot_make_file fs) + )) + +(def: (exists? fs) + (-> (IO (/.System Promise)) Test) + (<| (do {! random.monad} + [file (random.ascii/numeric 2) + dir (random.filter (|>> (text\= file) not) + (random.ascii/numeric 2))]) + wrap + (do {! promise.monad} + [fs (promise.future fs) + + pre_file/0 (\ fs file? file) + pre_file/1 (/.exists? ! fs file) + pre_dir/0 (\ fs directory? dir) + pre_dir/1 (/.exists? ! fs dir) + + made_file? (/.make_file ! fs (utf8\encode file) file) + made_dir? (\ fs make_directory dir) + + post_file/0 (\ fs file? file) + post_file/1 (/.exists? ! fs file) + post_dir/0 (\ fs directory? dir) + post_dir/1 (/.exists? ! fs dir)]) + (_.cover' [/.exists?] + (and (not pre_file/0) + (not pre_file/1) + (not pre_dir/0) + (not pre_dir/1) + + (case made_file? + (#try.Success _) true + (#try.Failure _) false) + (case made_dir? + (#try.Success _) true + (#try.Failure _) false) + + post_file/0 + post_file/1 + post_dir/0 + post_dir/1)))) + +(def: #export (spec fs) + (-> (IO (/.System Promise)) Test) + ($_ _.and + (..for_path fs) + (..for_utilities fs) + (..for_system fs) + (..exists? fs) + )) diff --git a/stdlib/source/specification/lux/world/program.lux b/stdlib/source/specification/lux/world/program.lux new file mode 100644 index 000000000..e79429627 --- /dev/null +++ b/stdlib/source/specification/lux/world/program.lux @@ -0,0 +1,32 @@ +(.module: + [library + [lux #* + ["_" test (#+ Test)] + [abstract + [monad (#+ do)]] + [control + ["." try] + [concurrency + ["." promise (#+ Promise)]]] + [data + ["." text] + [collection + ["." dictionary] + ["." list]]] + [math + ["." random]]]] + [\\library + ["." /]]) + +(def: #export (spec subject) + (-> (/.Program Promise) Test) + (do random.monad + [exit random.int] + (wrap (do {! promise.monad} + [environment (/.environment ! subject)] + (_.cover' [/.Program] + (and (not (dictionary.empty? environment)) + (list.every? (|>> text.empty? not) + (dictionary.keys environment)) + (not (text.empty? (\ subject home))) + (not (text.empty? (\ subject directory))))))))) diff --git a/stdlib/source/specification/lux/world/shell.lux b/stdlib/source/specification/lux/world/shell.lux new file mode 100644 index 000000000..c4fc51b99 --- /dev/null +++ b/stdlib/source/specification/lux/world/shell.lux @@ -0,0 +1,92 @@ +(.module: + [library + [lux #* + ["_" test (#+ Test)] + [abstract + [monad (#+ do)]] + [control + ["." try ("#\." functor)] + [concurrency + ["." promise (#+ Promise) ("#\." monad)]] + [parser + ["." environment (#+ Environment)]]] + [data + ["." product] + ["." text ("#\." equivalence) + ["%" format (#+ format)]]] + [math + ["." random] + [number + ["n" nat] + ["i" int]]]]] + [\\library + ["." / + [// + [file (#+ Path)]]]]) + +(template [ ] + [(def: + (-> [Environment Path /.Command (List /.Argument)]) + (|>> list [environment.empty "~" ]))] + + [echo! "echo" Text (|>)] + [sleep! "sleep" Nat %.nat] + ) + +(def: (can_wait! process) + (-> (/.Process Promise) _.Assertion) + (|> (\ process await []) + (promise\map (|>> (try\map (i.= /.normal)) + (try.default false) + (_.cover' [/.Exit /.normal]))) + promise\join)) + +(def: (can_read! expected process) + (-> Text (/.Process Promise) (Promise Bit)) + (|> (\ process read []) + (promise\map (|>> (try\map (text\= expected)) + (try.default false))))) + +(def: (can_destroy! process) + (-> (/.Process Promise) (Promise Bit)) + (do promise.monad + [?destroy (\ process destroy []) + ?await (\ process await [])] + (wrap (and (case ?destroy + (#try.Success _) + true + + (#try.Failure error) + false) + (case ?await + (#try.Success _) + false + + (#try.Failure error) + true))))) + +(with_expansions [ (as_is [/.Command /.Argument])] + (def: #export (spec shell) + (-> (/.Shell Promise) Test) + (<| (_.for [/.Shell /.Process]) + (do {! random.monad} + [message (random.ascii/alpha 10) + seconds (\ ! map (|>> (n.% 5) (n.+ 5)) random.nat)] + (wrap (do {! promise.monad} + [?echo (\ shell execute (..echo! message)) + ?sleep (\ shell execute (..sleep! seconds))] + (case [?echo ?sleep] + [(#try.Success echo) (#try.Success sleep)] + (do ! + [can_read! (..can_read! message echo) + can_destroy! (..can_destroy! sleep)] + ($_ _.and' + (_.cover' + (and can_read! + can_destroy!)) + (..can_wait! echo) + )) + + _ + (_.cover' + false)))))))) -- cgit v1.2.3