From 1546feb83e8e821ee8bbf3dea736a49a072bcd52 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Sun, 31 May 2020 01:36:32 -0400 Subject: Re-enabled lux/tool tests. --- stdlib/source/lux/control/function/mixin.lux | 24 +- stdlib/source/lux/type.lux | 4 +- stdlib/source/lux/type/resource.lux | 9 +- stdlib/source/test/lux/control.lux | 41 +-- .../source/test/lux/control/concurrency/actor.lux | 17 +- stdlib/source/test/lux/control/function/memo.lux | 88 ++++-- stdlib/source/test/lux/control/function/mixin.lux | 135 +++++++++ stdlib/source/test/lux/tool.lux | 11 +- .../test/lux/tool/compiler/default/syntax.lux | 150 ---------- .../tool/compiler/language/lux/phase/analysis.lux | 24 ++ .../compiler/language/lux/phase/analysis/case.lux | 208 ++++++++++++++ .../language/lux/phase/analysis/function.lux | 132 +++++++++ .../language/lux/phase/analysis/primitive.lux | 114 ++++++++ .../language/lux/phase/analysis/reference.lux | 107 +++++++ .../language/lux/phase/analysis/structure.lux | 309 +++++++++++++++++++++ .../language/lux/phase/extension/analysis/lux.lux | 206 ++++++++++++++ .../tool/compiler/language/lux/phase/synthesis.lux | 17 ++ .../compiler/language/lux/phase/synthesis/case.lux | 105 +++++++ .../language/lux/phase/synthesis/function.lux | 190 +++++++++++++ .../language/lux/phase/synthesis/primitive.lux | 84 ++++++ .../language/lux/phase/synthesis/structure.lux | 81 ++++++ .../test/lux/tool/compiler/language/lux/syntax.lux | 150 ++++++++++ .../test/lux/tool/compiler/phase/analysis.lux | 24 -- .../test/lux/tool/compiler/phase/analysis/case.lux | 203 -------------- .../lux/tool/compiler/phase/analysis/function.lux | 127 --------- .../lux/tool/compiler/phase/analysis/primitive.lux | 110 -------- .../lux/tool/compiler/phase/analysis/reference.lux | 103 ------- .../lux/tool/compiler/phase/analysis/structure.lux | 305 -------------------- .../tool/compiler/phase/extension/analysis/lux.lux | 201 -------------- .../test/lux/tool/compiler/phase/synthesis.lux | 17 -- .../lux/tool/compiler/phase/synthesis/case.lux | 101 ------- .../lux/tool/compiler/phase/synthesis/function.lux | 185 ------------ .../tool/compiler/phase/synthesis/primitive.lux | 80 ------ .../tool/compiler/phase/synthesis/structure.lux | 77 ----- 34 files changed, 1984 insertions(+), 1755 deletions(-) create mode 100644 stdlib/source/test/lux/control/function/mixin.lux delete mode 100644 stdlib/source/test/lux/tool/compiler/default/syntax.lux create mode 100644 stdlib/source/test/lux/tool/compiler/language/lux/phase/analysis.lux create mode 100644 stdlib/source/test/lux/tool/compiler/language/lux/phase/analysis/case.lux create mode 100644 stdlib/source/test/lux/tool/compiler/language/lux/phase/analysis/function.lux create mode 100644 stdlib/source/test/lux/tool/compiler/language/lux/phase/analysis/primitive.lux create mode 100644 stdlib/source/test/lux/tool/compiler/language/lux/phase/analysis/reference.lux create mode 100644 stdlib/source/test/lux/tool/compiler/language/lux/phase/analysis/structure.lux create mode 100644 stdlib/source/test/lux/tool/compiler/language/lux/phase/extension/analysis/lux.lux create mode 100644 stdlib/source/test/lux/tool/compiler/language/lux/phase/synthesis.lux create mode 100644 stdlib/source/test/lux/tool/compiler/language/lux/phase/synthesis/case.lux create mode 100644 stdlib/source/test/lux/tool/compiler/language/lux/phase/synthesis/function.lux create mode 100644 stdlib/source/test/lux/tool/compiler/language/lux/phase/synthesis/primitive.lux create mode 100644 stdlib/source/test/lux/tool/compiler/language/lux/phase/synthesis/structure.lux create mode 100644 stdlib/source/test/lux/tool/compiler/language/lux/syntax.lux delete mode 100644 stdlib/source/test/lux/tool/compiler/phase/analysis.lux delete mode 100644 stdlib/source/test/lux/tool/compiler/phase/analysis/case.lux delete mode 100644 stdlib/source/test/lux/tool/compiler/phase/analysis/function.lux delete mode 100644 stdlib/source/test/lux/tool/compiler/phase/analysis/primitive.lux delete mode 100644 stdlib/source/test/lux/tool/compiler/phase/analysis/reference.lux delete mode 100644 stdlib/source/test/lux/tool/compiler/phase/analysis/structure.lux delete mode 100644 stdlib/source/test/lux/tool/compiler/phase/extension/analysis/lux.lux delete mode 100644 stdlib/source/test/lux/tool/compiler/phase/synthesis.lux delete mode 100644 stdlib/source/test/lux/tool/compiler/phase/synthesis/case.lux delete mode 100644 stdlib/source/test/lux/tool/compiler/phase/synthesis/function.lux delete mode 100644 stdlib/source/test/lux/tool/compiler/phase/synthesis/primitive.lux delete mode 100644 stdlib/source/test/lux/tool/compiler/phase/synthesis/structure.lux (limited to 'stdlib/source') diff --git a/stdlib/source/lux/control/function/mixin.lux b/stdlib/source/lux/control/function/mixin.lux index 4a79bb99a..328115ec4 100644 --- a/stdlib/source/lux/control/function/mixin.lux +++ b/stdlib/source/lux/control/function/mixin.lux @@ -18,13 +18,13 @@ (def: #export nothing Mixin - (function (_ super self) - super)) + (function (_ delegate recur) + delegate)) (def: #export (inherit parent child) (All [m] (-> (Mixin m) (Mixin m) (Mixin m))) - (function (_ super self) - (parent (child super self) self))) + (function (_ delegate recur) + (parent (child delegate recur) recur))) (structure: #export monoid (All [m] (Monoid (Mixin m))) @@ -32,14 +32,6 @@ (def: identity ..nothing) (def: compose ..inherit)) -(type: #export (Recursive i o) - (-> (-> i o) (-> i o))) - -(def: #export (from-recursive recursive) - (All [i o] (-> (Recursive i o) (Mixin (-> i o)))) - (function (_ delegate recur) - (recursive recur))) - (def: #export (advice when then) (All [i o] (-> (Predicate i) (Mixin (-> i o)) (Mixin (-> i o)))) (function (_ delegate recur input) @@ -61,3 +53,11 @@ [output (delegate input) _ (action input output)] (wrap output)))) + +(type: #export (Recursive i o) + (-> (-> i o) (-> i o))) + +(def: #export (from-recursive recursive) + (All [i o] (-> (Recursive i o) (Mixin (-> i o)))) + (function (_ delegate recur) + (recursive recur))) diff --git a/stdlib/source/lux/type.lux b/stdlib/source/lux/type.lux index 73453902a..0356d6b85 100644 --- a/stdlib/source/lux/type.lux +++ b/stdlib/source/lux/type.lux @@ -168,7 +168,9 @@ type )) -(structure: #export equivalence (Equivalence Type) +(structure: #export equivalence + (Equivalence Type) + (def: (= x y) (or (is? x y) (case [x y] diff --git a/stdlib/source/lux/type/resource.lux b/stdlib/source/lux/type/resource.lux index a49c49f2a..1e81d37c1 100644 --- a/stdlib/source/lux/type/resource.lux +++ b/stdlib/source/lux/type/resource.lux @@ -112,7 +112,8 @@ [ordered-async Promise promise.monad Ordered ordered-key] [commutative-sync IO io.monad Commutative commutative-key] [commutative-pure Identity identity.monad Commutative commutative-key] - [commutative-async Promise promise.monad Commutative commutative-key]) + [commutative-async Promise promise.monad Commutative commutative-key] + ) (template [ ] [(def: #export ( resource) @@ -123,7 +124,8 @@ [read-pure Identity identity.monad] [read-sync IO io.monad] - [read-async Promise promise.monad])) + [read-async Promise promise.monad] + )) (exception: #export (index-cannot-be-repeated {index Nat}) (exception.report @@ -181,7 +183,8 @@ [exchange-pure Identity identity.monad] [exchange-sync IO io.monad] - [exchange-async Promise promise.monad]) + [exchange-async Promise promise.monad] + ) (def: amount (Parser Nat) diff --git a/stdlib/source/test/lux/control.lux b/stdlib/source/test/lux/control.lux index 5c7f7b9ef..56be46610 100644 --- a/stdlib/source/test/lux/control.lux +++ b/stdlib/source/test/lux/control.lux @@ -3,34 +3,34 @@ ["_" test (#+ Test)]] ["." / #_ ["#." concatenative] + [concurrency + ["#." actor] + ["#." atom] + ["#." frp] + ["#." process] + ["#." promise] + ["#." semaphore] + ["#." stm]] ["#." continuation] ["#." exception] ["#." function + ["#/." contract] ["#/." memo] - ["#/." contract]] + ["#/." mixin]] ["#." try] ["#." io] - ["#." parser] + ["#." parser + ["#/." text] + ["#/." cli]] ["#." pipe] ["#." reader] ["#." region] ["#." remember] + [security + ["#." policy]] ["#." state] ["#." thread] - ["#." writer] - [concurrency - ["#." actor] - ["#." atom] - ["#." frp] - ["#." process] - ["#." promise] - ["#." semaphore] - ["#." stm]] - ["#." parser #_ - ["#/." text] - ["#/." cli]] - [security - ["#." policy]]]) + ["#." writer]]) (def: concurrency Test @@ -48,8 +48,9 @@ Test ($_ _.and /function.test - /function/memo.test /function/contract.test + /function/memo.test + /function/mixin.test )) (def: parser @@ -70,19 +71,19 @@ Test ($_ _.and /concatenative.test + ..concurrency /continuation.test /exception.test ..function - /try.test /io.test ..parser /pipe.test /reader.test /region.test /remember.test + ..security /state.test /thread.test + /try.test /writer.test - ..concurrency - ..security )) diff --git a/stdlib/source/test/lux/control/concurrency/actor.lux b/stdlib/source/test/lux/control/concurrency/actor.lux index fe9362b07..f63de1509 100644 --- a/stdlib/source/test/lux/control/concurrency/actor.lux +++ b/stdlib/source/test/lux/control/concurrency/actor.lux @@ -84,14 +84,15 @@ (promise.promise []))] (:: random.monad wrap (do promise.monad - [result (promise.future (do io.monad - [actor (/.spawn {#/.handle (function (_ message state self) - (message state self)) - #/.end (function (_ cause state) - (promise.future (write cause)))} - write) - _ (/.poison actor)] - (promise.poll read)))] + [_ (promise.future (do io.monad + [actor (/.spawn {#/.handle (function (_ message state self) + (message state self)) + #/.end (function (_ cause state) + (promise.future (write cause)))} + write)] + (/.poison actor))) + _ (promise.wait 100) + result (promise.future (promise.poll read))] (_.claim [/.poisoned] (case result (#.Some error) diff --git a/stdlib/source/test/lux/control/function/memo.lux b/stdlib/source/test/lux/control/function/memo.lux index 5b5c91271..a00b8bc58 100644 --- a/stdlib/source/test/lux/control/function/memo.lux +++ b/stdlib/source/test/lux/control/function/memo.lux @@ -1,16 +1,20 @@ (.module: [lux #* ["_" test (#+ Test)] - [abstract/monad (#+ do)] - ["%" data/text/format (#+ format)] + [abstract + [monad (#+ do)]] [control ["." io (#+ IO)] - ["." state ("#@." monad)]] + ["." state (#+ State) ("#@." monad)]] [math - ["r" random]] + ["." random]] [data + ["." product] [number - ["n" nat]]] + ["n" nat]] + [collection + ["." dictionary (#+ Dictionary)] + ["." list ("#@." functor fold)]]] [time ["." instant] ["." duration (#+ Duration)]]] @@ -19,14 +23,14 @@ ["/#" // #_ ["#" mixin]]]}) -(def: (fibonacci fibonacci input) +(def: (fibonacci recur input) (/.Memo Nat Nat) (case input 0 (state@wrap 0) 1 (state@wrap 1) _ (do state.monad - [output-1 (fibonacci (n.- 1 input)) - output-2 (fibonacci (n.- 2 input))] + [output-1 (recur (n.- 1 input)) + output-2 (recur (n.- 2 input))] (wrap (n.+ output-1 output-2))))) (def: (time function input) @@ -38,20 +42,58 @@ (wrap [(instant.span before after) output]))) +(def: milli-seconds + (-> Duration Nat) + (|>> (duration.query duration.milli-second) .nat)) + (def: #export test Test - (<| (_.context (%.name (name-of /.memoization))) - (let [fast (/.closed n.hash fibonacci) - slow (/.none n.hash ..fibonacci)] - (do r.monad - [input (wrap 30) - #let [prefix (format (%.name (name-of /.memoization)) " => " (%.nat input) " => ")]] - (_.test "Memoization makes certain computations faster." - (io.run - (do io.monad - [[fast-time fast-output] (..time fast input) - [slow-time slow-output] (..time slow input) - #let [_ (log! (format prefix " memoized = " (%.duration fast-time))) - _ (log! (format prefix "non-memoized = " (%.duration slow-time)))]] - (wrap (and (n.= fast-output slow-output) - (:: duration.order < slow-time fast-time)))))))))) + (<| (_.covering /._) + (do {@ random.monad} + [input (|> random.nat (:: @ map (|>> (n.% 6) (n.+ 20))))]) + (_.with-cover [/.Memo]) + ($_ _.and + (_.cover [/.closed /.none] + (io.run + (do io.monad + [#let [slow (/.none n.hash ..fibonacci) + fast (/.closed n.hash fibonacci)] + [slow-time slow-output] (..time slow input) + [fast-time fast-output] (..time fast input)] + (wrap (and (n.= slow-output + fast-output) + (n.< (milli-seconds slow-time) + (milli-seconds fast-time))))))) + (_.cover [/.open] + (io.run + (do io.monad + [#let [none (/.none n.hash ..fibonacci) + memory (dictionary.new n.hash) + open (/.open fibonacci)] + [none-time none-output] (..time none input) + [open-time [memory open-output]] (..time open [memory input]) + [open-time/+1 _] (..time open [memory (inc input)])] + (wrap (and (n.= none-output + open-output) + (n.< (milli-seconds none-time) + (milli-seconds open-time)) + (n.< (milli-seconds open-time) + (milli-seconds open-time/+1))))))) + (_.cover [/.memoization] + (let [memo (<| //.mixin + (//.inherit /.memoization) + (: (//.Mixin (-> Nat (State (Dictionary Nat Nat) Nat))) + (function (factorial delegate recur input) + (case input + (^or 0 1) (:: state.monad wrap 1) + _ (do state.monad + [output' (recur (dec input))] + (wrap (n.* input output'))))))) + expected (|> (list.indices input) + (list@map inc) + (list@fold n.* 1)) + actual (|> (memo input) + (state.run (dictionary.new n.hash)) + product.right)] + (n.= expected actual))) + ))) diff --git a/stdlib/source/test/lux/control/function/mixin.lux b/stdlib/source/test/lux/control/function/mixin.lux new file mode 100644 index 000000000..b9f2e766f --- /dev/null +++ b/stdlib/source/test/lux/control/function/mixin.lux @@ -0,0 +1,135 @@ +(.module: + [lux #* + ["_" test (#+ Test)] + [abstract + [equivalence (#+ Equivalence)] + [predicate (#+ Predicate)] + [monad (#+ do)] + {[0 #test] + [/ + ["$." monoid]]}] + [control + ["." state (#+ State)]] + [data + ["." product] + [number + ["n" nat]] + [collection + ["." list ("#@." functor fold)]]] + [math + ["." random (#+ Random)]]] + {1 + ["." /]}) + +(def: #export test + Test + (<| (_.covering /._) + (do {@ random.monad} + [input (|> random.nat (:: @ map (|>> (n.% 6) (n.+ 20)))) + dummy random.nat + shift (|> random.nat (random.filter (|>> (n.= dummy) not))) + #let [equivalence (: (Equivalence (/.Mixin (-> Nat Nat))) + (structure + (def: (= left right) + (n.= ((/.mixin left) input) + ((/.mixin right) input))))) + generator (: (Random (/.Mixin (-> Nat Nat))) + (do @ + [output random.nat] + (wrap (function (_ delegate recur input) + output)))) + expected (|> (list.indices input) + (list@map inc) + (list@fold n.* 1))]]) + ($_ _.and + (_.with-cover [/.Mixin] + ($_ _.and + (_.with-cover [/.monoid] + ($monoid.spec equivalence /.monoid generator)) + + (_.cover [/.mixin] + (let [factorial (/.mixin + (function (_ delegate recur input) + (case input + (^or 0 1) 1 + _ (n.* input (recur (dec input))))))] + (n.= expected + (factorial input)))) + (_.cover [/.inherit] + (let [bottom (: (/.Mixin (-> Nat Nat)) + (function (_ delegate recur input) + (case input + (^or 0 1) 1 + _ (delegate input)))) + multiplication (: (/.Mixin (-> Nat Nat)) + (function (_ delegate recur input) + (n.* input (recur (dec input))))) + factorial (/.mixin (/.inherit bottom multiplication))] + (n.= expected + (factorial input)))) + (_.cover [/.nothing] + (let [loop (: (/.Mixin (-> Nat Nat)) + (function (_ delegate recur input) + (case input + (^or 0 1) 1 + _ (n.* input (delegate (dec input)))))) + left (/.mixin (/.inherit /.nothing loop)) + right (/.mixin (/.inherit loop /.nothing))] + (and (n.= expected + (left input)) + (n.= expected + (right input))))) + (_.cover [/.advice] + (let [bottom (: (/.Mixin (-> Nat Nat)) + (function (_ delegate recur input) + 1)) + bottom? (: (Predicate Nat) + (function (_ input) + (case input + (^or 0 1) true + _ false))) + multiplication (: (/.Mixin (-> Nat Nat)) + (function (_ delegate recur input) + (n.* input (recur (dec input))))) + factorial (/.mixin (/.inherit (/.advice bottom? bottom) + multiplication))] + (n.= expected + (factorial input)))) + (_.cover [/.before] + (let [implant (: (-> Nat (State Nat [])) + (function (_ input) + (function (_ state) + [shift []]))) + meld (: (/.Mixin (-> Nat (State Nat Nat))) + (function (_ delegate recur input) + (function (_ state) + [state (n.+ state input)]))) + function (/.mixin (/.inherit (/.before state.monad implant) + meld))] + (n.= (n.+ shift input) + (|> input function (state.run dummy) product.right)))) + (_.cover [/.after] + (let [implant (: (-> Nat Nat (State Nat [])) + (function (_ input output) + (function (_ state) + [shift []]))) + meld (: (/.Mixin (-> Nat (State Nat Nat))) + (function (_ delegate recur input) + (function (_ state) + [state (n.+ state input)]))) + function (/.mixin (/.inherit (/.after state.monad implant) + meld))] + (n.= (n.+ dummy input) + (|> input function (state.run dummy) product.right)))) + )) + (_.with-cover [/.Recursive] + (_.cover [/.from-recursive] + (let [factorial (/.mixin + (/.from-recursive + (function (_ recur input) + (case input + (^or 0 1) 1 + _ (n.* input (recur (dec input)))))))] + (n.= expected + (factorial input))))) + ))) diff --git a/stdlib/source/test/lux/tool.lux b/stdlib/source/test/lux/tool.lux index 7d1c2676e..5452fbb65 100644 --- a/stdlib/source/test/lux/tool.lux +++ b/stdlib/source/test/lux/tool.lux @@ -3,11 +3,12 @@ ["_" test (#+ Test)]] ["." / #_ [compiler - [default - ["#." syntax]] - [phase - ["#." analysis] - ["#." synthesis]]]]) + [language + [lux + ["#." syntax] + [phase + ["#." analysis] + ["#." synthesis]]]]]]) (def: #export test Test diff --git a/stdlib/source/test/lux/tool/compiler/default/syntax.lux b/stdlib/source/test/lux/tool/compiler/default/syntax.lux deleted file mode 100644 index 4baa57891..000000000 --- a/stdlib/source/test/lux/tool/compiler/default/syntax.lux +++ /dev/null @@ -1,150 +0,0 @@ -(.module: - [lux #* - [abstract/monad (#+ do)] - [data - ["%" text/format (#+ format)] - ["." name] - [number - ["n" nat]]] - ["r" math/random (#+ Random) ("#@." monad)] - ["_" test (#+ Test)] - [control - ["." try] - [parser - ["l" text]]] - [data - ["." text] - [collection - ["." list] - ["." dictionary (#+ Dictionary)]]] - [macro - ["." code]]] - {1 - ["." /]}) - -(def: default-cursor - Cursor - {#.module "" - #.line 0 - #.column 0}) - -(def: name-part^ - (Random Text) - (do {@ r.monad} - [size (|> r.nat (:: @ map (|>> (n.% 20) (n.max 1))))] - (r.ascii/lower-alpha size))) - -(def: name^ - (Random Name) - (r.and name-part^ name-part^)) - -(def: code^ - (Random Code) - (let [numeric^ (: (Random Code) - ($_ r.either - (|> r.bit (r@map code.bit)) - (|> r.nat (r@map code.nat)) - (|> r.int (r@map code.int)) - (|> r.rev (r@map code.rev)) - (|> r.safe-frac (r@map code.frac)))) - textual^ (: (Random Code) - ($_ r.either - (do r.monad - [size (|> r.nat (r@map (n.% 20)))] - (|> (r.ascii/upper-alpha size) (r@map code.text))) - (|> name^ (r@map code.identifier)) - (|> name^ (r@map code.tag)))) - simple^ (: (Random Code) - ($_ r.either - numeric^ - textual^))] - (r.rec - (function (_ code^) - (let [multi^ (do r.monad - [size (|> r.nat (r@map (n.% 3)))] - (r.list size code^)) - composite^ (: (Random Code) - ($_ r.either - (|> multi^ (r@map code.form)) - (|> multi^ (r@map code.tuple)) - (do r.monad - [size (|> r.nat (r@map (n.% 3)))] - (|> (r.list size (r.and code^ code^)) - (r@map code.record)))))] - ($_ r.either - simple^ - composite^)))))) - -(def: code - Test - (do {@ r.monad} - [sample code^] - ($_ _.and - (_.test "Can parse Lux code." - (case (let [source-code (%.code sample)] - (/.parse "" (dictionary.new text.hash) (text.size source-code) - [default-cursor 0 source-code])) - (#.Left error) - false - - (#.Right [_ parsed]) - (:: code.equivalence = parsed sample))) - (do @ - [other code^] - (_.test "Can parse Lux multiple code nodes." - (let [source-code (format (%.code sample) " " (%.code other)) - source-code//size (text.size source-code)] - (case (/.parse "" (dictionary.new text.hash) source-code//size - [default-cursor 0 source-code]) - (#.Left error) - false - - (#.Right [remaining =sample]) - (case (/.parse "" (dictionary.new text.hash) source-code//size - remaining) - (#.Left error) - false - - (#.Right [_ =other]) - (and (:: code.equivalence = sample =sample) - (:: code.equivalence = other =other))))))) - ))) - -(def: comment-text^ - (Random Text) - (let [char-gen (|> r.nat (r.filter (|>> (n.= (`` (char (~~ (static text.new-line))))) not)))] - (do r.monad - [size (|> r.nat (r@map (n.% 20)))] - (r.text char-gen size)))) - -(def: comment^ - (Random Text) - (do r.monad - [comment comment-text^] - (wrap (format "## " comment text.new-line)))) - -(def: comments - Test - (do r.monad - [sample code^ - comment comment^] - ($_ _.and - (_.test "Can handle comments." - (case (let [source-code (format comment (%.code sample)) - source-code//size (text.size source-code)] - (/.parse "" (dictionary.new text.hash) source-code//size - [default-cursor 0 source-code])) - (#.Left error) - false - - (#.Right [_ parsed]) - (:: code.equivalence = parsed sample))) - ))) - -(def: #export test - Test - (<| (_.context (name.module (name-of /._))) - ($_ _.and - ..code - ..comments - ))) diff --git a/stdlib/source/test/lux/tool/compiler/language/lux/phase/analysis.lux b/stdlib/source/test/lux/tool/compiler/language/lux/phase/analysis.lux new file mode 100644 index 000000000..06b09fbf9 --- /dev/null +++ b/stdlib/source/test/lux/tool/compiler/language/lux/phase/analysis.lux @@ -0,0 +1,24 @@ +(.module: + [lux #* + ["_" test (#+ Test)]] + ["." / #_ + ["#." primitive] + ["#." structure] + ["#." reference] + ["#." case] + ["#." function] + ["/#" // #_ + [extension + [analysis + ["#." lux]]]]]) + +(def: #export test + Test + ($_ _.and + /primitive.test + /structure.test + /reference.test + /case.test + /function.test + //lux.test + )) diff --git a/stdlib/source/test/lux/tool/compiler/language/lux/phase/analysis/case.lux b/stdlib/source/test/lux/tool/compiler/language/lux/phase/analysis/case.lux new file mode 100644 index 000000000..71c523649 --- /dev/null +++ b/stdlib/source/test/lux/tool/compiler/language/lux/phase/analysis/case.lux @@ -0,0 +1,208 @@ +(.module: + [lux #* + [abstract ["." monad (#+ do)]] + [data + ["%" text/format (#+ format)] + ["." name ("#@." equivalence)]] + ["r" math/random (#+ Random) ("#@." monad)] + ["_" test (#+ Test)] + [control + pipe] + [data + ["." product] + ["." maybe] + ["." text ("#@." equivalence)] + [number + ["n" nat]] + [collection + ["." list ("#@." monad)] + ["." set]]] + ["." type + ["." check]] + [macro + ["." code]]] + [// + ["_." primitive] + ["_." structure]] + {1 + ["." / + ["/#" // + ["#." module] + ["#." type] + ["/#" // #_ + ["/#" // + ["#." analysis (#+ Analysis Variant Tag Operation)] + [/// + ["." phase] + [meta + ["." archive]]]]]]]}) + +(def: (exhaustive-weaving branchings) + (-> (List (List Code)) (List (List Code))) + (case branchings + #.Nil + #.Nil + + (#.Cons head+ #.Nil) + (list@map (|>> list) head+) + + (#.Cons head+ tail++) + (do list.monad + [tail+ (exhaustive-weaving tail++) + head head+] + (wrap (#.Cons head tail+))))) + +(def: #export (exhaustive-branches allow-literals? variantTC inputC) + (-> Bit (List [Code Code]) Code (Random (List Code))) + (case inputC + [_ (#.Bit _)] + (r@wrap (list (' #0) (' #1))) + + (^template [ ] + [_ ( _)] + (if allow-literals? + (do {@ r.monad} + [?sample (r.maybe )] + (case ?sample + (#.Some sample) + (do @ + [else (exhaustive-branches allow-literals? variantTC inputC)] + (wrap (list& ( sample) else))) + + #.None + (wrap (list (' _))))) + (r@wrap (list (' _))))) + ([#.Nat r.nat code.nat] + [#.Int r.int code.int] + [#.Rev r.rev code.rev] + [#.Frac r.frac code.frac] + [#.Text (r.unicode 5) code.text]) + + (^ [_ (#.Tuple (list))]) + (r@wrap (list (' []))) + + [_ (#.Tuple members)] + (do {@ r.monad} + [member-wise-patterns (monad.map @ (exhaustive-branches allow-literals? variantTC) members)] + (wrap (|> member-wise-patterns + exhaustive-weaving + (list@map code.tuple)))) + + (^ [_ (#.Record (list))]) + (r@wrap (list (' {}))) + + [_ (#.Record kvs)] + (do {@ r.monad} + [#let [ks (list@map product.left kvs) + vs (list@map product.right kvs)] + member-wise-patterns (monad.map @ (exhaustive-branches allow-literals? variantTC) vs)] + (wrap (|> member-wise-patterns + exhaustive-weaving + (list@map (|>> (list.zip2 ks) code.record))))) + + (^ [_ (#.Form (list [_ (#.Tag _)] _))]) + (do {@ r.monad} + [bundles (monad.map @ + (function (_ [_tag _code]) + (do @ + [v-branches (exhaustive-branches allow-literals? variantTC _code)] + (wrap (list@map (function (_ pattern) (` ((~ _tag) (~ pattern)))) + v-branches)))) + variantTC)] + (wrap (list@join bundles))) + + _ + (r@wrap (list)) + )) + +(def: #export (input variant-tags record-tags primitivesC) + (-> (List Code) (List Code) (List Code) (Random Code)) + (r.rec + (function (_ input) + ($_ r.either + (r@map product.right _primitive.primitive) + (do {@ r.monad} + [choice (|> r.nat (:: @ map (n.% (list.size variant-tags)))) + #let [choiceT (maybe.assume (list.nth choice variant-tags)) + choiceC (maybe.assume (list.nth choice primitivesC))]] + (wrap (` ((~ choiceT) (~ choiceC))))) + (do {@ r.monad} + [size (|> r.nat (:: @ map (n.% 3))) + elems (r.list size input)] + (wrap (code.tuple elems))) + (r@wrap (code.record (list.zip2 record-tags primitivesC))) + )))) + +(def: (branch body pattern) + (-> Code Code [Code Code]) + [pattern body]) + +(def: #export test + (<| (_.context (name.module (name-of /._))) + (do {@ r.monad} + [module-name (r.unicode 5) + variant-name (r.unicode 5) + record-name (|> (r.unicode 5) (r.filter (|>> (text@= variant-name) not))) + size (|> r.nat (:: @ map (|>> (n.% 10) (n.max 2)))) + variant-tags (|> (r.set text.hash size (r.unicode 5)) (:: @ map set.to-list)) + record-tags (|> (r.set text.hash size (r.unicode 5)) (:: @ map set.to-list)) + primitivesTC (r.list size _primitive.primitive) + #let [primitivesT (list@map product.left primitivesTC) + primitivesC (list@map product.right primitivesTC) + code-tag (|>> [module-name] code.tag) + variant-tags+ (list@map code-tag variant-tags) + record-tags+ (list@map code-tag record-tags) + variantTC (list.zip2 variant-tags+ primitivesC)] + inputC (input variant-tags+ record-tags+ primitivesC) + [outputT outputC] (r.filter (|>> product.left (is? Any) not) + _primitive.primitive) + #let [analyse-pm (function (_ branches) + (|> (/.case _primitive.phase branches archive.empty inputC) + (//type.with-type outputT) + ////analysis.with-scope + (do phase.monad + [_ (//module.declare-tags variant-tags false + (#.Named [module-name variant-name] + (type.variant primitivesT))) + _ (//module.declare-tags record-tags false + (#.Named [module-name record-name] + (type.tuple primitivesT)))]) + (//module.with-module 0 module-name)))] + exhaustive-patterns (exhaustive-branches true variantTC inputC) + #let [exhaustive-branchesC (list@map (branch outputC) + exhaustive-patterns)]] + ($_ _.and + (_.test "Will reject empty pattern-matching (no branches)." + (|> (analyse-pm (list)) + _structure.check-fails)) + (_.test "Can analyse exhaustive pattern-matching." + (|> (analyse-pm exhaustive-branchesC) + _structure.check-succeeds)) + (let [non-exhaustive-branchesC (list.take (dec (list.size exhaustive-branchesC)) + exhaustive-branchesC)] + (_.test "Will reject non-exhaustive pattern-matching." + (|> (analyse-pm non-exhaustive-branchesC) + _structure.check-fails))) + (do @ + [redundant-patterns (exhaustive-branches false variantTC inputC) + redundancy-idx (|> r.nat (:: @ map (n.% (list.size redundant-patterns)))) + #let [redundant-branchesC (<| (list@map (branch outputC)) + list.concat + (list (list.take redundancy-idx redundant-patterns) + (list (maybe.assume (list.nth redundancy-idx redundant-patterns))) + (list.drop redundancy-idx redundant-patterns)))]] + (_.test "Will reject redundant pattern-matching." + (|> (analyse-pm redundant-branchesC) + _structure.check-fails))) + (do @ + [[heterogeneousT heterogeneousC] (r.filter (|>> product.left (check.checks? outputT) not) + _primitive.primitive) + heterogeneous-idx (|> r.nat (:: @ map (n.% (list.size exhaustive-patterns)))) + #let [heterogeneous-branchesC (list.concat (list (list.take heterogeneous-idx exhaustive-branchesC) + (list (let [[_pattern _body] (maybe.assume (list.nth heterogeneous-idx exhaustive-branchesC))] + [_pattern heterogeneousC])) + (list.drop (inc heterogeneous-idx) exhaustive-branchesC)))]] + (_.test "Will reject pattern-matching if the bodies of the branches do not all have the same type." + (|> (analyse-pm heterogeneous-branchesC) + _structure.check-fails))) + )))) diff --git a/stdlib/source/test/lux/tool/compiler/language/lux/phase/analysis/function.lux b/stdlib/source/test/lux/tool/compiler/language/lux/phase/analysis/function.lux new file mode 100644 index 000000000..3dbacc0e2 --- /dev/null +++ b/stdlib/source/test/lux/tool/compiler/language/lux/phase/analysis/function.lux @@ -0,0 +1,132 @@ +(.module: + [lux #* + [abstract + ["." monad (#+ do)]] + [data + ["%" text/format (#+ format)] + ["." name ("#@." equivalence)]] + ["r" math/random (#+ Random) ("#@." monad)] + ["_" test (#+ Test)] + [control + pipe + ["." try]] + [data + ["." maybe] + ["." product] + ["." text ("#@." equivalence)] + [number + ["n" nat]] + [collection + ["." list ("#@." functor)]]] + ["." type] + ["." macro + ["." code]]] + [// + ["_." primitive] + ["_." structure]] + {1 + ["." / + ["/#" // + ["#." module] + ["#." type] + ["/#" // #_ + ["/#" // + ["#." analysis (#+ Analysis Operation)] + [/// + ["#." reference] + ["." phase] + [meta + ["." archive]]]]]]]}) + +(def: (check-apply expectedT num-args analysis) + (-> Type Nat (Operation Analysis) Bit) + (|> analysis + (//type.with-type expectedT) + (phase.run _primitive.state) + (case> (#try.Success applyA) + (let [[funcA argsA] (////analysis.application applyA)] + (n.= num-args (list.size argsA))) + + (#try.Failure _) + false))) + +(def: abstraction + (do r.monad + [func-name (r.unicode 5) + arg-name (|> (r.unicode 5) (r.filter (|>> (text@= func-name) not))) + [outputT outputC] _primitive.primitive + [inputT _] _primitive.primitive + #let [g!arg (code.local-identifier arg-name)]] + (<| (_.context (%.name (name-of /.function))) + ($_ _.and + (_.test "Can analyse function." + (and (|> (//type.with-type (All [a] (-> a outputT)) + (/.function _primitive.phase func-name arg-name archive.empty outputC)) + _structure.check-succeeds) + (|> (//type.with-type (All [a] (-> a a)) + (/.function _primitive.phase func-name arg-name archive.empty g!arg)) + _structure.check-succeeds))) + (_.test "Generic functions can always be specialized." + (and (|> (//type.with-type (-> inputT outputT) + (/.function _primitive.phase func-name arg-name archive.empty outputC)) + _structure.check-succeeds) + (|> (//type.with-type (-> inputT inputT) + (/.function _primitive.phase func-name arg-name archive.empty g!arg)) + _structure.check-succeeds))) + (_.test "The function's name is bound to the function's type." + (|> (//type.with-type (Rec self (-> inputT self)) + (/.function _primitive.phase func-name arg-name archive.empty (code.local-identifier func-name))) + _structure.check-succeeds)) + )))) + +(def: apply + (do {@ r.monad} + [full-args (|> r.nat (:: @ map (|>> (n.% 10) (n.max 2)))) + partial-args (|> r.nat (:: @ map (n.% full-args))) + var-idx (|> r.nat (:: @ map (|>> (n.% full-args) (n.max 1)))) + inputsTC (r.list full-args _primitive.primitive) + #let [inputsT (list@map product.left inputsTC) + inputsC (list@map product.right inputsTC)] + [outputT outputC] _primitive.primitive + #let [funcT (type.function inputsT outputT) + partialT (type.function (list.drop partial-args inputsT) outputT) + varT (#.Parameter 1) + polyT (<| (type.univ-q 1) + (type.function (list.concat (list (list.take var-idx inputsT) + (list varT) + (list.drop (inc var-idx) inputsT)))) + varT) + poly-inputT (maybe.assume (list.nth var-idx inputsT)) + partial-poly-inputsT (list.drop (inc var-idx) inputsT) + partial-polyT1 (<| (type.function partial-poly-inputsT) + poly-inputT) + partial-polyT2 (<| (type.univ-q 1) + (type.function (#.Cons varT partial-poly-inputsT)) + varT) + dummy-function (#////analysis.Function (list) (#////analysis.Reference (////reference.local 1)))]] + (<| (_.context (%.name (name-of /.apply))) + ($_ _.and + (_.test "Can analyse monomorphic type application." + (|> (/.apply _primitive.phase inputsC funcT dummy-function archive.empty (' [])) + (check-apply outputT full-args))) + (_.test "Can partially apply functions." + (|> (/.apply _primitive.phase (list.take partial-args inputsC) funcT dummy-function archive.empty (' [])) + (check-apply partialT partial-args))) + (_.test "Can apply polymorphic functions." + (|> (/.apply _primitive.phase inputsC polyT dummy-function archive.empty (' [])) + (check-apply poly-inputT full-args))) + (_.test "Polymorphic partial application propagates found type-vars." + (|> (/.apply _primitive.phase (list.take (inc var-idx) inputsC) polyT dummy-function archive.empty (' [])) + (check-apply partial-polyT1 (inc var-idx)))) + (_.test "Polymorphic partial application preserves quantification for type-vars." + (|> (/.apply _primitive.phase (list.take var-idx inputsC) polyT dummy-function archive.empty (' [])) + (check-apply partial-polyT2 var-idx))) + )))) + +(def: #export test + Test + (<| (_.context (name.module (name-of /._))) + ($_ _.and + ..abstraction + ..apply + ))) diff --git a/stdlib/source/test/lux/tool/compiler/language/lux/phase/analysis/primitive.lux b/stdlib/source/test/lux/tool/compiler/language/lux/phase/analysis/primitive.lux new file mode 100644 index 000000000..d2864e6a1 --- /dev/null +++ b/stdlib/source/test/lux/tool/compiler/language/lux/phase/analysis/primitive.lux @@ -0,0 +1,114 @@ +(.module: + [lux (#- primitive) + ["@" target] + [abstract + ["." monad (#+ do)]] + [data + ["%" text/format (#+ format)] + ["." name]] + ["r" math/random (#+ Random) ("#@." monad)] + ["_" test (#+ Test)] + [control + pipe + ["." try (#+ Try)] + ["." exception (#+ exception:)]] + ["." type ("#@." equivalence)] + [macro + ["." code]]] + {1 + ["." / + ["/#" // + ["#." type] + ["/#" // #_ + [extension + ["." bundle] + ["#." analysis]] + ["/#" // #_ + ["." version] + ["#." analysis (#+ Analysis Operation) + [macro (#+ Expander)] + [evaluation (#+ Eval)]] + [/// + ["." phase] + [meta + ["." archive]]]]]]]}) + +(def: #export (expander macro inputs state) + Expander + (#try.Failure "NOPE")) + +(def: #export (eval archive count type expression) + Eval + (function (_ state) + (#try.Failure "NO!"))) + +(def: #export phase + ////analysis.Phase + (//.phase ..expander)) + +(def: #export state + ////analysis.State+ + [(///analysis.bundle ..eval bundle.empty) + (////analysis.state (////analysis.info version.version @.jvm))]) + +(def: #export primitive + (Random [Type Code]) + (`` ($_ r.either + (~~ (template [ ] + [(r.and (r@wrap ) (r@map ))] + + [Any code.tuple (r.list 0 (r@wrap (' [])))] + [Bit code.bit r.bit] + [Nat code.nat r.nat] + [Int code.int r.int] + [Rev code.rev r.rev] + [Frac code.frac r.frac] + [Text code.text (r.unicode 5)] + ))))) + +(exception: (wrong-inference {expected Type} {inferred Type}) + (exception.report + ["Expected" (%.type expected)] + ["Inferred" (%.type inferred)])) + +(def: (infer expected-type analysis) + (-> Type (Operation Analysis) (Try Analysis)) + (|> analysis + //type.with-inference + (phase.run ..state) + (case> (#try.Success [inferred-type output]) + (if (is? expected-type inferred-type) + (#try.Success output) + (exception.throw wrong-inference [expected-type inferred-type])) + + (#try.Failure error) + (#try.Failure error)))) + +(def: #export test + (<| (_.context (name.module (name-of /._))) + (`` ($_ _.and + (_.test (%.name (name-of #////analysis.Unit)) + (|> (infer Any (..phase archive.empty (' []))) + (case> (^ (#try.Success (#////analysis.Primitive (#////analysis.Unit output)))) + (is? [] output) + + _ + false))) + (~~ (template [ ] + [(do r.monad + [sample ] + (_.test (%.name (name-of )) + (|> (infer (..phase archive.empty ( sample))) + (case> (#try.Success (#////analysis.Primitive ( output))) + (is? sample output) + + _ + false))))] + + [Bit #////analysis.Bit r.bit code.bit] + [Nat #////analysis.Nat r.nat code.nat] + [Int #////analysis.Int r.int code.int] + [Rev #////analysis.Rev r.rev code.rev] + [Frac #////analysis.Frac r.frac code.frac] + [Text #////analysis.Text (r.unicode 5) code.text] + )))))) diff --git a/stdlib/source/test/lux/tool/compiler/language/lux/phase/analysis/reference.lux b/stdlib/source/test/lux/tool/compiler/language/lux/phase/analysis/reference.lux new file mode 100644 index 000000000..7197dbca6 --- /dev/null +++ b/stdlib/source/test/lux/tool/compiler/language/lux/phase/analysis/reference.lux @@ -0,0 +1,107 @@ +(.module: + [lux #* + [abstract ["." monad (#+ do)]] + [data + ["." name ("#@." equivalence)]] + ["r" math/random (#+ Random) ("#@." monad)] + ["_" test (#+ Test)] + [control + pipe + ["." try (#+ Try)]] + [data + ["." text ("#@." equivalence)] + [number + ["n" nat]]] + ["." type ("#@." equivalence)] + [macro + ["." code]]] + [// + ["_." primitive]] + {1 + ["." / + ["/#" // + ["#." scope] + ["#." module] + ["#." type] + ["/#" // #_ + ["/#" // + ["#." analysis (#+ Analysis Variant Tag Operation)] + [/// + ["#." reference] + ["." phase] + [meta + ["." archive]]]]]]]}) + +(type: Check (-> (Try Any) Bit)) + +(template [ ] + [(def: + Check + (|>> (case> (#try.Success _) + + + (#try.Failure _) + )))] + + [success? true false] + [failure? false true] + ) + +(def: (reach-test var-name [export? def-module] [import? dependent-module] check!) + (-> Text [Bit Text] [Bit Text] Check Bit) + (|> (do {@ phase.monad} + [_ (//module.with-module 0 def-module + (//module.define var-name (#.Right [export? Any (' {}) []])))] + (//module.with-module 0 dependent-module + (do @ + [_ (if import? + (//module.import def-module) + (wrap []))] + (//type.with-inference + (_primitive.phase archive.empty (code.identifier [def-module var-name])))))) + (phase.run _primitive.state) + check!)) + +(def: #export test + (<| (_.context (name.module (name-of /._))) + (do r.monad + [[expectedT _] _primitive.primitive + def-module (r.unicode 5) + scope-name (r.unicode 5) + var-name (r.unicode 5) + dependent-module (|> (r.unicode 5) + (r.filter (|>> (text@= def-module) not)))] + ($_ _.and + (_.test "Can analyse variable." + (|> (//scope.with-scope scope-name + (//scope.with-local [var-name expectedT] + (//type.with-inference + (_primitive.phase archive.empty (code.local-identifier var-name))))) + (phase.run _primitive.state) + (case> (^ (#try.Success [inferredT (#////analysis.Reference (////reference.local var))])) + (and (type@= expectedT inferredT) + (n.= 0 var)) + + _ + false))) + (_.test "Can analyse definition (in the same module)." + (let [def-name [def-module var-name]] + (|> (do phase.monad + [_ (//module.define var-name (#.Right [false expectedT (' {}) []]))] + (//type.with-inference + (_primitive.phase archive.empty (code.identifier def-name)))) + (//module.with-module 0 def-module) + (phase.run _primitive.state) + (case> (^ (#try.Success [_ inferredT (#////analysis.Reference (////reference.constant constant-name))])) + (and (type@= expectedT inferredT) + (name@= def-name constant-name)) + + _ + false)))) + (_.test "Can analyse definition (if exported from imported module)." + (reach-test var-name [true def-module] [true dependent-module] success?)) + (_.test "Cannot analyse definition (if not exported from imported module)." + (reach-test var-name [false def-module] [true dependent-module] failure?)) + (_.test "Cannot analyse definition (if exported from non-imported module)." + (reach-test var-name [true def-module] [false dependent-module] failure?)) + )))) diff --git a/stdlib/source/test/lux/tool/compiler/language/lux/phase/analysis/structure.lux b/stdlib/source/test/lux/tool/compiler/language/lux/phase/analysis/structure.lux new file mode 100644 index 000000000..fb3c1fe60 --- /dev/null +++ b/stdlib/source/test/lux/tool/compiler/language/lux/phase/analysis/structure.lux @@ -0,0 +1,309 @@ +(.module: + [lux #* + [abstract ["." monad (#+ do)]] + [data + ["%" text/format (#+ format)] + ["." name]] + ["r" math/random (#+ Random) ("#@." monad)] + ["_" test (#+ Test)] + [control + pipe + ["." try]] + [data + ["." bit ("#@." equivalence)] + ["." product] + ["." maybe] + ["." text] + [number + ["n" nat]] + [collection + ["." list ("#@." functor)] + ["." set]]] + ["." type + ["." check]] + [macro + ["." code]]] + [// + ["_." primitive]] + {1 + ["." / + ["/#" // + ["#." module] + ["#." type] + ["/#" // #_ + ["/#" // + ["#." analysis (#+ Analysis Variant Tag Operation)] + [/// + ["." phase] + [meta + ["." archive]]]]]]]}) + +(template [ ] + [(def: #export + (All [a] (-> (Operation a) Bit)) + (|>> (phase.run _primitive.state) + (case> (#try.Success _) + + + _ + )))] + + [check-succeeds true false] + [check-fails false true] + ) + +(def: (check-sum' tag size variant) + (-> Tag Nat (Variant Analysis) Bit) + (let [expected//right? (n.= (dec size) tag) + expected//lefts (if expected//right? + (dec tag) + tag) + actual//right? (get@ #////analysis.right? variant) + actual//lefts (get@ #////analysis.lefts variant)] + (and (n.= expected//lefts + actual//lefts) + (bit@= expected//right? + actual//right?)))) + +(def: (check-sum type tag size analysis) + (-> Type Tag Nat (Operation Analysis) Bit) + (|> analysis + (//type.with-type type) + (phase.run _primitive.state) + (case> (^ (#try.Success (////analysis.variant variant))) + (check-sum' tag size variant) + + _ + false))) + +(def: (with-tags module tags type) + (All [a] (-> Text (List //module.Tag) Type (Operation a) (Operation [Module a]))) + (|>> (do phase.monad + [_ (//module.declare-tags tags false type)]) + (//module.with-module 0 module))) + +(def: (check-variant module tags expectedT variantT tag analysis) + (-> Text (List //module.Tag) Type Type Tag (Operation Analysis) Bit) + (|> analysis + (with-tags module tags variantT) + (//type.with-type expectedT) + (phase.run _primitive.state) + (case> (^ (#try.Success [_ (////analysis.variant variant)])) + (check-sum' tag (list.size tags) variant) + + _ + false))) + +(def: (correct-size? size) + (-> Nat (-> Analysis Bit)) + (|>> (case> (^ (////analysis.tuple elems)) + (|> elems + list.size + (n.= size)) + + _ + false))) + +(def: (check-record module tags expectedT recordT size analysis) + (-> Text (List //module.Tag) Type Type Nat (Operation Analysis) Bit) + (|> analysis + (with-tags module tags recordT) + (//type.with-type expectedT) + (phase.run _primitive.state) + (case> (#try.Success [_ productA]) + (correct-size? size productA) + + _ + false))) + +(def: sum + (do {@ r.monad} + [size (|> r.nat (:: @ map (|>> (n.% 10) (n.max 2)))) + choice (|> r.nat (:: @ map (n.% size))) + primitives (r.list size _primitive.primitive) + +choice (|> r.nat (:: @ map (n.% (inc size)))) + [_ +valueC] _primitive.primitive + #let [variantT (type.variant (list@map product.left primitives)) + [valueT valueC] (maybe.assume (list.nth choice primitives)) + +size (inc size) + +primitives (list.concat (list (list.take choice primitives) + (list [(#.Parameter 1) +valueC]) + (list.drop choice primitives))) + [+valueT +valueC] (maybe.assume (list.nth +choice +primitives)) + +variantT (type.variant (list@map product.left +primitives))]] + (<| (_.context (%.name (name-of /.sum))) + ($_ _.and + (_.test "Can analyse." + (check-sum variantT choice size + (/.sum _primitive.phase choice archive.empty valueC))) + (_.test "Can analyse through bound type-vars." + (|> (do phase.monad + [[_ varT] (//type.with-env check.var) + _ (//type.with-env + (check.check varT variantT))] + (//type.with-type varT + (/.sum _primitive.phase choice archive.empty valueC))) + (phase.run _primitive.state) + (case> (^ (#try.Success (////analysis.variant variant))) + (check-sum' choice size variant) + + _ + false))) + (_.test "Cannot analyse through unbound type-vars." + (|> (do phase.monad + [[_ varT] (//type.with-env check.var)] + (//type.with-type varT + (/.sum _primitive.phase choice archive.empty valueC))) + check-fails)) + (_.test "Can analyse through existential quantification." + (|> (//type.with-type (type.ex-q 1 +variantT) + (/.sum _primitive.phase +choice archive.empty +valueC)) + check-succeeds)) + (_.test "Can analyse through universal quantification." + (let [check-outcome (if (not (n.= choice +choice)) + check-succeeds + check-fails)] + (|> (//type.with-type (type.univ-q 1 +variantT) + (/.sum _primitive.phase +choice archive.empty +valueC)) + check-outcome))) + )))) + +(def: product + (do {@ r.monad} + [size (|> r.nat (:: @ map (|>> (n.% 10) (n.max 2)))) + primitives (r.list size _primitive.primitive) + choice (|> r.nat (:: @ map (n.% size))) + [_ +valueC] _primitive.primitive + #let [tupleT (type.tuple (list@map product.left primitives)) + [singletonT singletonC] (|> primitives (list.nth choice) maybe.assume) + +primitives (list.concat (list (list.take choice primitives) + (list [(#.Parameter 1) +valueC]) + (list.drop choice primitives))) + +tupleT (type.tuple (list@map product.left +primitives))]] + (<| (_.context (%.name (name-of /.product))) + ($_ _.and + (_.test "Can analyse." + (|> (//type.with-type tupleT + (/.product archive.empty _primitive.phase (list@map product.right primitives))) + (phase.run _primitive.state) + (case> (#try.Success tupleA) + (correct-size? size tupleA) + + _ + false))) + (_.test "Can infer." + (|> (//type.with-inference + (/.product archive.empty _primitive.phase (list@map product.right primitives))) + (phase.run _primitive.state) + (case> (#try.Success [_type tupleA]) + (and (check.checks? tupleT _type) + (correct-size? size tupleA)) + + _ + false))) + (_.test "Can analyse singleton." + (|> (//type.with-type singletonT + (_primitive.phase archive.empty (` [(~ singletonC)]))) + check-succeeds)) + (_.test "Can analyse through bound type-vars." + (|> (do phase.monad + [[_ varT] (//type.with-env check.var) + _ (//type.with-env + (check.check varT (type.tuple (list@map product.left primitives))))] + (//type.with-type varT + (/.product archive.empty _primitive.phase (list@map product.right primitives)))) + (phase.run _primitive.state) + (case> (#try.Success tupleA) + (correct-size? size tupleA) + + _ + false))) + (_.test "Can analyse through existential quantification." + (|> (//type.with-type (type.ex-q 1 +tupleT) + (/.product archive.empty _primitive.phase (list@map product.right +primitives))) + check-succeeds)) + (_.test "Cannot analyse through universal quantification." + (|> (//type.with-type (type.univ-q 1 +tupleT) + (/.product archive.empty _primitive.phase (list@map product.right +primitives))) + check-fails)) + )))) + +(def: variant + (do {@ r.monad} + [size (|> r.nat (:: @ map (|>> (n.% 10) (n.max 2)))) + tags (|> (r.set text.hash size (r.unicode 5)) (:: @ map set.to-list)) + choice (|> r.nat (:: @ map (n.% size))) + other-choice (|> r.nat (:: @ map (n.% size)) (r.filter (|>> (n.= choice) not))) + primitives (r.list size _primitive.primitive) + module-name (r.unicode 5) + type-name (r.unicode 5) + #let [with-name (|>> (#.Named [module-name type-name])) + varT (#.Parameter 1) + primitivesT (list@map product.left primitives) + [choiceT choiceC] (maybe.assume (list.nth choice primitives)) + [other-choiceT other-choiceC] (maybe.assume (list.nth other-choice primitives)) + monoT (type.variant primitivesT) + polyT (|> (type.variant (list.concat (list (list.take choice primitivesT) + (list varT) + (list.drop (inc choice) primitivesT)))) + (type.univ-q 1)) + choice-tag (maybe.assume (list.nth choice tags)) + other-choice-tag (maybe.assume (list.nth other-choice tags))]] + (<| (_.context (%.name (name-of /.tagged-sum))) + ($_ _.and + (_.test "Can infer." + (|> (/.tagged-sum _primitive.phase [module-name choice-tag] archive.empty choiceC) + (check-variant module-name tags + monoT (with-name monoT) + choice))) + (_.test "Inference retains universal quantification when type-vars are not bound." + (|> (/.tagged-sum _primitive.phase [module-name other-choice-tag] archive.empty other-choiceC) + (check-variant module-name tags + polyT (with-name polyT) + other-choice))) + (_.test "Can specialize." + (|> (//type.with-type monoT + (/.tagged-sum _primitive.phase [module-name other-choice-tag] archive.empty other-choiceC)) + (check-variant module-name tags + monoT (with-name polyT) + other-choice))) + (_.test "Specialization when type-vars get bound." + (|> (/.tagged-sum _primitive.phase [module-name choice-tag] archive.empty choiceC) + (check-variant module-name tags + monoT (with-name polyT) + choice))) + )))) + +(def: record + (do {@ r.monad} + [size (|> r.nat (:: @ map (|>> (n.% 10) (n.max 2)))) + tags (|> (r.set text.hash size (r.unicode 5)) (:: @ map set.to-list)) + primitives (r.list size _primitive.primitive) + module-name (r.unicode 5) + type-name (r.unicode 5) + choice (|> r.nat (:: @ map (n.% size))) + #let [varT (#.Parameter 1) + tagsC (list@map (|>> [module-name] code.tag) tags) + primitivesT (list@map product.left primitives) + primitivesC (list@map product.right primitives) + monoT (#.Named [module-name type-name] (type.tuple primitivesT)) + recordC (list.zip2 tagsC primitivesC) + polyT (|> (type.tuple (list.concat (list (list.take choice primitivesT) + (list varT) + (list.drop (inc choice) primitivesT)))) + (type.univ-q 1) + (#.Named [module-name type-name]))]] + (<| (_.context (%.name (name-of /.record))) + (_.test "Can infer." + (|> (/.record archive.empty _primitive.phase recordC) + (check-record module-name tags monoT monoT size)))))) + +(def: #export test + Test + (<| (_.context (name.module (name-of /._))) + ($_ _.and + ..sum + ..product + ..variant + ..record + ))) diff --git a/stdlib/source/test/lux/tool/compiler/language/lux/phase/extension/analysis/lux.lux b/stdlib/source/test/lux/tool/compiler/language/lux/phase/extension/analysis/lux.lux new file mode 100644 index 000000000..a7686e0f2 --- /dev/null +++ b/stdlib/source/test/lux/tool/compiler/language/lux/phase/extension/analysis/lux.lux @@ -0,0 +1,206 @@ +(.module: + [lux (#- i64 int primitive) + [abstract + ["." monad (#+ do)]] + [data + ["%" text/format (#+ format)] + ["." name]] + ["r" math/random (#+ Random) ("#@." monad)] + ["_" test (#+ Test)] + [control + pipe + [io (#+ IO)] + ["." try] + [concurrency + ["." atom]]] + [data + ["." product]] + ["." type ("#@." equivalence)] + [macro + ["." code]]] + [//// + [analysis + ["_." primitive]]] + {1 + ["." / + ["///#" //// #_ + [analysis + ["#." scope] + ["#." type]] + [//// + ["." phase] + [meta + ["." archive]]]]]}) + +(template [ ] + [(def: ( procedure params output-type) + (-> Text (List Code) Type Bit) + (|> (////scope.with-scope "" + (////type.with-type output-type + (_primitive.phase archive.empty (` ((~ (code.text procedure)) (~+ params)))))) + (phase.run _primitive.state) + (case> (#try.Success _) + + + (#try.Failure _) + )))] + + [check-success+ true false] + [check-failure+ false true] + ) + +(def: primitive + (Random [Type Code]) + (r.filter (|>> product.left (is? Any) not) _primitive.primitive)) + +(def: lux + Test + (do r.monad + [[primT primC] ..primitive + [antiT antiC] (|> ..primitive + (r.filter (|>> product.left (type@= primT) not)))] + ($_ _.and + (_.test "Can test for reference equality." + (check-success+ "lux is" (list primC primC) Bit)) + (_.test "Reference equality must be done with elements of the same type." + (check-failure+ "lux is" (list primC antiC) Bit)) + (_.test "Can 'try' risky IO computations." + (check-success+ "lux try" + (list (` ("lux io error" "YOLO"))) + (type (Either Text primT)))) + ))) + +(def: i64 + Test + (do {@ r.monad} + [subjectC (|> r.nat (:: @ map code.nat)) + signedC (|> r.int (:: @ map code.int)) + paramC (|> r.nat (:: @ map code.nat))] + ($_ _.and + (_.test "i64 'and'." + (check-success+ "lux i64 and" (list paramC subjectC) Nat)) + (_.test "i64 'or'." + (check-success+ "lux i64 or" (list paramC subjectC) Nat)) + (_.test "i64 'xor'." + (check-success+ "lux i64 xor" (list paramC subjectC) Nat)) + (_.test "i64 left-shift." + (check-success+ "lux i64 left-shift" (list paramC subjectC) Nat)) + (_.test "i64 logical-right-shift." + (check-success+ "lux i64 logical-right-shift" (list paramC subjectC) Nat)) + (_.test "i64 arithmetic-right-shift." + (check-success+ "lux i64 arithmetic-right-shift" (list paramC signedC) Int)) + (_.test "i64 equivalence." + (check-success+ "lux i64 =" (list paramC subjectC) Bit)) + (_.test "i64 addition." + (check-success+ "lux i64 +" (list paramC subjectC) Int)) + (_.test "i64 subtraction." + (check-success+ "lux i64 -" (list paramC subjectC) Int)) + ))) + +(def: int + Test + (do {@ r.monad} + [subjectC (|> r.int (:: @ map code.int)) + paramC (|> r.int (:: @ map code.int))] + ($_ _.and + (_.test "Can multiply integers." + (check-success+ "lux i64 *" (list paramC subjectC) Int)) + (_.test "Can divide integers." + (check-success+ "lux i64 /" (list paramC subjectC) Int)) + (_.test "Can calculate remainder of integers." + (check-success+ "lux i64 %" (list paramC subjectC) Int)) + (_.test "Can compare integers." + (check-success+ "lux i64 <" (list paramC subjectC) Bit)) + (_.test "Can convert integer to text." + (check-success+ "lux i64 char" (list subjectC) Text)) + (_.test "Can convert integer to fraction." + (check-success+ "lux i64 f64" (list subjectC) Frac)) + ))) + +(def: frac + Test + (do {@ r.monad} + [subjectC (|> r.safe-frac (:: @ map code.frac)) + paramC (|> r.safe-frac (:: @ map code.frac)) + encodedC (|> r.safe-frac (:: @ map (|>> %.frac code.text)))] + ($_ _.and + (_.test "Can add frac numbers." + (check-success+ "lux f64 +" (list paramC subjectC) Frac)) + (_.test "Can subtract frac numbers." + (check-success+ "lux f64 -" (list paramC subjectC) Frac)) + (_.test "Can multiply frac numbers." + (check-success+ "lux f64 *" (list paramC subjectC) Frac)) + (_.test "Can divide frac numbers." + (check-success+ "lux f64 /" (list paramC subjectC) Frac)) + (_.test "Can calculate remainder of frac numbers." + (check-success+ "lux f64 %" (list paramC subjectC) Frac)) + (_.test "Can test equivalence of frac numbers." + (check-success+ "lux f64 =" (list paramC subjectC) Bit)) + (_.test "Can compare frac numbers." + (check-success+ "lux f64 <" (list paramC subjectC) Bit)) + (_.test "Can obtain minimum frac number." + (check-success+ "lux f64 min" (list) Frac)) + (_.test "Can obtain maximum frac number." + (check-success+ "lux f64 max" (list) Frac)) + (_.test "Can obtain smallest frac number." + (check-success+ "lux f64 smallest" (list) Frac)) + (_.test "Can convert frac number to integer." + (check-success+ "lux f64 i64" (list subjectC) Int)) + (_.test "Can convert frac number to text." + (check-success+ "lux f64 encode" (list subjectC) Text)) + (_.test "Can convert text to frac number." + (check-success+ "lux f64 decode" (list encodedC) (type (Maybe Frac)))) + ))) + +(def: text + Test + (do {@ r.monad} + [subjectC (|> (r.unicode 5) (:: @ map code.text)) + paramC (|> (r.unicode 5) (:: @ map code.text)) + replacementC (|> (r.unicode 5) (:: @ map code.text)) + fromC (|> r.nat (:: @ map code.nat)) + toC (|> r.nat (:: @ map code.nat))] + ($_ _.and + (_.test "Can test text equivalence." + (check-success+ "lux text =" (list paramC subjectC) Bit)) + (_.test "Compare texts in lexicographical order." + (check-success+ "lux text <" (list paramC subjectC) Bit)) + (_.test "Can concatenate one text to another." + (check-success+ "lux text concat" (list subjectC paramC) Text)) + (_.test "Can find the index of a piece of text inside a larger one that (may) contain it." + (check-success+ "lux text index" (list fromC paramC subjectC) (type (Maybe Nat)))) + (_.test "Can query the size/length of a text." + (check-success+ "lux text size" (list subjectC) Nat)) + (_.test "Can obtain the character code of a text at a given index." + (check-success+ "lux text char" (list fromC subjectC) Nat)) + (_.test "Can clip a piece of text between 2 indices." + (check-success+ "lux text clip" (list fromC toC subjectC) Text)) + ))) + +(def: io + Test + (do {@ r.monad} + [logC (|> (r.unicode 5) (:: @ map code.text)) + exitC (|> r.int (:: @ map code.int))] + ($_ _.and + (_.test "Can log messages to standard output." + (check-success+ "lux io log" (list logC) Any)) + (_.test "Can throw a run-time error." + (check-success+ "lux io error" (list logC) Nothing)) + (_.test "Can exit the program." + (check-success+ "lux io exit" (list exitC) Nothing)) + (_.test "Can query the current time (as milliseconds since epoch)." + (check-success+ "lux io current-time" (list) Int)) + ))) + +(def: #export test + Test + (<| (_.context (name.module (name-of /._))) + ($_ _.and + ..lux + ..i64 + ..int + ..frac + ..text + ..io + ))) diff --git a/stdlib/source/test/lux/tool/compiler/language/lux/phase/synthesis.lux b/stdlib/source/test/lux/tool/compiler/language/lux/phase/synthesis.lux new file mode 100644 index 000000000..da9937862 --- /dev/null +++ b/stdlib/source/test/lux/tool/compiler/language/lux/phase/synthesis.lux @@ -0,0 +1,17 @@ +(.module: + [lux #* + ["_" test (#+ Test)]] + ["." / #_ + ["#." primitive] + ["#." structure] + ["#." case] + ["#." function]]) + +(def: #export test + Test + ($_ _.and + /primitive.test + /structure.test + /case.test + /function.test + )) diff --git a/stdlib/source/test/lux/tool/compiler/language/lux/phase/synthesis/case.lux b/stdlib/source/test/lux/tool/compiler/language/lux/phase/synthesis/case.lux new file mode 100644 index 000000000..5f9f14321 --- /dev/null +++ b/stdlib/source/test/lux/tool/compiler/language/lux/phase/synthesis/case.lux @@ -0,0 +1,105 @@ +(.module: + [lux #* + [abstract ["." monad (#+ do)]] + [data + ["." name] + [number + ["n" nat]]] + ["r" math/random (#+ Random) ("#@." monad)] + ["_" test (#+ Test)] + [control + pipe + ["." try ("#@." functor)]]] + ["." // #_ + ["#." primitive]] + {1 + ["." / + ["/#" // + ["/#" // #_ + [extension + ["#." bundle]] + ["/#" // + ["#." analysis (#+ Branch Analysis)] + ["#." synthesis (#+ Synthesis)] + [/// + ["#." reference] + ["." phase] + [meta + ["." archive]]]]]]]}) + +(def: dummy-vars + Test + (do {@ r.monad} + [maskedA //primitive.primitive + temp (|> r.nat (:: @ map (n.% 100))) + #let [maskA (////analysis.control/case + [maskedA + [[(#////analysis.Bind temp) + (#////analysis.Reference (////reference.local temp))] + (list)]])]] + (_.test "Dummy variables created to mask expressions get eliminated during synthesis." + (|> maskA + (//.phase archive.empty) + (phase.run [///bundle.empty ////synthesis.init]) + (try@map (//primitive.corresponds? maskedA)) + (try.default false))))) + +(def: let-expr + Test + (do r.monad + [registerA r.nat + inputA //primitive.primitive + outputA //primitive.primitive + #let [letA (////analysis.control/case + [inputA + [[(#////analysis.Bind registerA) + outputA] + (list)]])]] + (_.test "Can detect and reify simple 'let' expressions." + (|> letA + (//.phase archive.empty) + (phase.run [///bundle.empty ////synthesis.init]) + (case> (^ (#try.Success (////synthesis.branch/let [inputS registerS outputS]))) + (and (n.= registerA registerS) + (//primitive.corresponds? inputA inputS) + (//primitive.corresponds? outputA outputS)) + + _ + false))))) + +(def: if-expr + Test + (do r.monad + [then|else r.bit + inputA //primitive.primitive + thenA //primitive.primitive + elseA //primitive.primitive + #let [thenB (: Branch + [(#////analysis.Simple (#////analysis.Bit true)) + thenA]) + elseB (: Branch + [(#////analysis.Simple (#////analysis.Bit false)) + elseA]) + ifA (if then|else + (////analysis.control/case [inputA [thenB (list elseB)]]) + (////analysis.control/case [inputA [elseB (list thenB)]]))]] + (_.test "Can detect and reify simple 'if' expressions." + (|> ifA + (//.phase archive.empty) + (phase.run [///bundle.empty ////synthesis.init]) + (case> (^ (#try.Success (////synthesis.branch/if [inputS thenS elseS]))) + (and (//primitive.corresponds? inputA inputS) + (//primitive.corresponds? thenA thenS) + (//primitive.corresponds? elseA elseS)) + + _ + false))))) + +(def: #export test + Test + (<| (_.context (name.module (name-of /._))) + ($_ _.and + ..dummy-vars + ..let-expr + ..if-expr + ))) diff --git a/stdlib/source/test/lux/tool/compiler/language/lux/phase/synthesis/function.lux b/stdlib/source/test/lux/tool/compiler/language/lux/phase/synthesis/function.lux new file mode 100644 index 000000000..799a8a526 --- /dev/null +++ b/stdlib/source/test/lux/tool/compiler/language/lux/phase/synthesis/function.lux @@ -0,0 +1,190 @@ +(.module: + [lux #* + [abstract + ["." monad (#+ do)]] + [data + ["." name]] + ["r" math/random (#+ Random) ("#@." monad)] + ["_" test (#+ Test)] + [control + pipe + ["." try]] + [data + ["." product] + ["." maybe] + [number + ["n" nat]] + [collection + ["." list ("#@." functor fold)] + ["dict" dictionary (#+ Dictionary)] + ["." set]]]] + ["." // #_ + ["#." primitive]] + {1 + ["." / + ["/#" // + ["/#" // #_ + [extension + ["#." bundle]] + ["/#" // + ["#." analysis (#+ Analysis)] + ["#." synthesis (#+ Synthesis)] + [/// + [arity (#+ Arity)] + ["#." reference (#+ Variable) ("variable@." equivalence)] + ["." phase] + [meta + ["." archive]]]]]]]}) + +(def: constant-function + (Random [Arity Analysis Analysis]) + (r.rec + (function (_ constant-function) + (do {@ r.monad} + [function? r.bit] + (if function? + (do @ + [[arity bodyA predictionA] constant-function] + (wrap [(inc arity) + (#////analysis.Function (list) bodyA) + predictionA])) + (do @ + [predictionA //primitive.primitive] + (wrap [0 predictionA predictionA]))))))) + +(def: (pick scope-size) + (-> Nat (Random Nat)) + (|> r.nat (:: r.monad map (n.% scope-size)))) + +(def: function-with-environment + (Random [Arity Analysis Variable]) + (do {@ r.monad} + [num-locals (|> r.nat (:: @ map (|>> (n.% 100) (n.max 10)))) + #let [indices (list.n/range 0 (dec num-locals)) + local-env (list@map (|>> #////reference.Local) indices) + foreign-env (list@map (|>> #////reference.Foreign) indices)] + [arity bodyA predictionA] (: (Random [Arity Analysis Variable]) + (loop [arity 1 + current-env foreign-env] + (let [current-env/size (list.size current-env) + resolver (list@fold (function (_ [idx var] resolver) + (dict.put idx var resolver)) + (: (Dictionary Nat Variable) + (dict.new n.hash)) + (list.enumerate current-env))] + (do @ + [nest? r.bit] + (if nest? + (do @ + [num-picks (:: @ map (n.max 1) (pick (inc current-env/size))) + picks (|> (r.set n.hash num-picks (pick current-env/size)) + (:: @ map set.to-list)) + [arity bodyA predictionA] (recur (inc arity) + (list@map (function (_ pick) + (maybe.assume (list.nth pick current-env))) + picks)) + #let [picked-env (list@map (|>> #////reference.Foreign) picks)]] + (wrap [arity + (#////analysis.Function picked-env bodyA) + predictionA])) + (do @ + [chosen (pick (list.size current-env))] + (wrap [arity + (#////analysis.Reference (////reference.foreign chosen)) + (maybe.assume (dict.get chosen resolver))])))))))] + (wrap [arity + (#////analysis.Function local-env bodyA) + predictionA]))) + +(def: local-function + (Random [Arity Analysis Variable]) + (loop [arity 0 + nest? #1] + (if nest? + (do r.monad + [nest?' r.bit + [arity' bodyA predictionA] (recur (inc arity) nest?')] + (wrap [arity' + (#////analysis.Function (list) bodyA) + predictionA])) + (do {@ r.monad} + [chosen (|> r.nat (:: @ map (|>> (n.% 100) (n.max 2))))] + (wrap [arity + (#////analysis.Reference (////reference.local chosen)) + (|> chosen (n.+ (dec arity)) #////reference.Local)]))))) + +(def: abstraction + Test + (do r.monad + [[arity//constant function//constant prediction//constant] constant-function + [arity//environment function//environment prediction//environment] function-with-environment + [arity//local function//local prediction//local] local-function] + ($_ _.and + (_.test "Nested functions will get folded together." + (|> function//constant + (//.phase archive.empty) + (phase.run [///bundle.empty ////synthesis.init]) + (case> (^ (#try.Success (////synthesis.function/abstraction [environment arity output]))) + (and (n.= arity//constant arity) + (//primitive.corresponds? prediction//constant output)) + + _ + (n.= 0 arity//constant)))) + (_.test "Folded functions provide direct access to environment variables." + (|> function//environment + (//.phase archive.empty) + (phase.run [///bundle.empty ////synthesis.init]) + (case> (^ (#try.Success (////synthesis.function/abstraction [environment arity (#////synthesis.Reference (////reference.variable output))]))) + (and (n.= arity//environment arity) + (variable@= prediction//environment output)) + + _ + #0))) + (_.test "Folded functions properly offset local variables." + (|> function//local + (//.phase archive.empty) + (phase.run [///bundle.empty ////synthesis.init]) + (case> (^ (#try.Success (////synthesis.function/abstraction [environment arity (#////synthesis.Reference (////reference.variable output))]))) + (and (n.= arity//local arity) + (variable@= prediction//local output)) + + _ + #0))) + ))) + +(def: application + Test + (do {@ r.monad} + [arity (|> r.nat (:: @ map (|>> (n.% 10) (n.max 1)))) + funcA //primitive.primitive + argsA (r.list arity //primitive.primitive)] + ($_ _.and + (_.test "Can synthesize function application." + (|> (////analysis.apply [funcA argsA]) + (//.phase archive.empty) + (phase.run [///bundle.empty ////synthesis.init]) + (case> (^ (#try.Success (////synthesis.function/apply [funcS argsS]))) + (and (//primitive.corresponds? funcA funcS) + (list.every? (product.uncurry //primitive.corresponds?) + (list.zip2 argsA argsS))) + + _ + #0))) + (_.test "Function application on no arguments just synthesizes to the function itself." + (|> (////analysis.apply [funcA (list)]) + (//.phase archive.empty) + (phase.run [///bundle.empty ////synthesis.init]) + (case> (#try.Success funcS) + (//primitive.corresponds? funcA funcS) + + _ + #0))) + ))) + +(def: #export test + Test + (<| (_.context (name.module (name-of /._))) + ($_ _.and + ..abstraction + ..application + ))) diff --git a/stdlib/source/test/lux/tool/compiler/language/lux/phase/synthesis/primitive.lux b/stdlib/source/test/lux/tool/compiler/language/lux/phase/synthesis/primitive.lux new file mode 100644 index 000000000..cd7fe54eb --- /dev/null +++ b/stdlib/source/test/lux/tool/compiler/language/lux/phase/synthesis/primitive.lux @@ -0,0 +1,84 @@ +(.module: + [lux (#- primitive) + [abstract ["." monad (#+ do)]] + [data + ["%" text/format (#+ format)] + ["." name]] + ["r" math/random (#+ Random) ("#@." monad)] + ["_" test (#+ Test)] + [control + pipe + ["." try]]] + {1 + ["." / #_ + ["/#" // + ["/#" // #_ + [extension + ["#." bundle]] + ["/#" // + ["#." analysis (#+ Analysis)] + ["#." synthesis (#+ Synthesis)] + [/// + ["." phase] + [meta + ["." archive]]]]]]]}) + +(def: #export primitive + (Random Analysis) + (do r.monad + [primitive (: (Random ////analysis.Primitive) + ($_ r.or + (wrap []) + r.bit + r.nat + r.int + r.rev + r.frac + (r.unicode 5)))] + (wrap (#////analysis.Primitive primitive)))) + +(def: #export (corresponds? analysis synthesis) + (-> Analysis Synthesis Bit) + (`` (case [analysis synthesis] + (~~ (template [ ] + [[(#////analysis.Primitive ( expected)) + (#////synthesis.Primitive ( actual))] + (is? (|> expected ) + (|> actual ))] + + [#////analysis.Unit (:coerce Text) #////synthesis.Text (|>)] + [#////analysis.Bit (|>) #////synthesis.Bit (|>)] + [#////analysis.Nat .i64 #////synthesis.I64 .i64] + [#////analysis.Int .i64 #////synthesis.I64 .i64] + [#////analysis.Rev .i64 #////synthesis.I64 .i64] + [#////analysis.Frac (|>) #////synthesis.F64 (|>)] + [#////analysis.Text (|>) #////synthesis.Text (|>)] + )) + + _ + false))) + +(def: #export test + Test + (<| (_.context (%.name (name-of #////synthesis.Primitive))) + (`` ($_ _.and + (~~ (template [ ] + [(do r.monad + [expected ] + (_.test (%.name (name-of )) + (|> (#////analysis.Primitive ( expected)) + (//.phase archive.empty) + (phase.run [///bundle.empty ////synthesis.init]) + (case> (#try.Success (#////synthesis.Primitive ( actual))) + (is? expected actual) + + _ + false))))] + + [#////analysis.Unit #////synthesis.Text (r@wrap ////synthesis.unit)] + [#////analysis.Bit #////synthesis.Bit r.bit] + [#////analysis.Nat #////synthesis.I64 (r@map .i64 r.nat)] + [#////analysis.Int #////synthesis.I64 (r@map .i64 r.int)] + [#////analysis.Rev #////synthesis.I64 (r@map .i64 r.rev)] + [#////analysis.Frac #////synthesis.F64 r.frac] + [#////analysis.Text #////synthesis.Text (r.unicode 5)])))))) diff --git a/stdlib/source/test/lux/tool/compiler/language/lux/phase/synthesis/structure.lux b/stdlib/source/test/lux/tool/compiler/language/lux/phase/synthesis/structure.lux new file mode 100644 index 000000000..7dea796fc --- /dev/null +++ b/stdlib/source/test/lux/tool/compiler/language/lux/phase/synthesis/structure.lux @@ -0,0 +1,81 @@ +(.module: + [lux #* + [abstract ["." monad (#+ do)]] + [data + ["%" text/format (#+ format)] + ["." name]] + ["r" math/random (#+ Random) ("#@." monad)] + ["_" test (#+ Test)] + [control + pipe + ["." try]] + [data + ["." bit ("#@." equivalence)] + ["." product] + [number + ["n" nat]] + [collection + ["." list]]]] + ["." // #_ + ["#." primitive]] + {1 + ["." / #_ + ["/#" // + ["/#" // #_ + [extension + ["#." bundle]] + ["/#" // + ["#." analysis (#+ Analysis)] + ["#." synthesis (#+ Synthesis)] + [/// + ["." phase] + [meta + ["." archive]]]]]]]}) + +(def: variant + Test + (do {@ r.monad} + [size (|> r.nat (:: @ map (|>> (n.% 10) (n.+ 2)))) + tagA (|> r.nat (:: @ map (n.% size))) + #let [right? (n.= (dec size) tagA) + lefts (if right? + (dec tagA) + tagA)] + memberA //primitive.primitive] + (_.test "Can synthesize variants." + (|> (////analysis.variant [lefts right? memberA]) + (//.phase archive.empty) + (phase.run [///bundle.empty ////synthesis.init]) + (case> (^ (#try.Success (////synthesis.variant [leftsS right?S valueS]))) + (let [tagS (if right?S (inc leftsS) leftsS)] + (and (n.= tagA tagS) + (|> tagS (n.= (dec size)) (bit@= right?S)) + (//primitive.corresponds? memberA valueS))) + + _ + false))))) + +(def: tuple + Test + (do {@ r.monad} + [size (|> r.nat (:: @ map (|>> (n.% 10) (n.max 2)))) + membersA (r.list size //primitive.primitive)] + (_.test "Can synthesize tuple." + (|> (////analysis.tuple membersA) + (//.phase archive.empty) + (phase.run [///bundle.empty ////synthesis.init]) + (case> (^ (#try.Success (////synthesis.tuple membersS))) + (and (n.= size (list.size membersS)) + (list.every? (product.uncurry //primitive.corresponds?) + (list.zip2 membersA membersS))) + + _ + false))))) + +(def: #export test + Test + (<| (_.context (%.name (name-of #////synthesis.Structure))) + ($_ _.and + ..variant + ..tuple + ))) diff --git a/stdlib/source/test/lux/tool/compiler/language/lux/syntax.lux b/stdlib/source/test/lux/tool/compiler/language/lux/syntax.lux new file mode 100644 index 000000000..103dc069e --- /dev/null +++ b/stdlib/source/test/lux/tool/compiler/language/lux/syntax.lux @@ -0,0 +1,150 @@ +(.module: + [lux #* + [abstract/monad (#+ do)] + [data + ["%" text/format (#+ format)] + ["." name] + [number + ["n" nat]]] + ["r" math/random (#+ Random) ("#@." monad)] + ["_" test (#+ Test)] + [control + ["." try] + [parser + ["l" text]]] + [data + ["." text] + [collection + ["." list] + ["." dictionary (#+ Dictionary)]]] + [macro + ["." code]]] + {1 + ["." /]}) + +(def: default-cursor + Cursor + {#.module "" + #.line 0 + #.column 0}) + +(def: name-part^ + (Random Text) + (do {@ r.monad} + [size (|> r.nat (:: @ map (|>> (n.% 20) (n.max 1))))] + (r.ascii/lower-alpha size))) + +(def: name^ + (Random Name) + (r.and name-part^ name-part^)) + +(def: code^ + (Random Code) + (let [numeric^ (: (Random Code) + ($_ r.either + (|> r.bit (r@map code.bit)) + (|> r.nat (r@map code.nat)) + (|> r.int (r@map code.int)) + (|> r.rev (r@map code.rev)) + (|> r.safe-frac (r@map code.frac)))) + textual^ (: (Random Code) + ($_ r.either + (do r.monad + [size (|> r.nat (r@map (n.% 20)))] + (|> (r.ascii/upper-alpha size) (r@map code.text))) + (|> name^ (r@map code.identifier)) + (|> name^ (r@map code.tag)))) + simple^ (: (Random Code) + ($_ r.either + numeric^ + textual^))] + (r.rec + (function (_ code^) + (let [multi^ (do r.monad + [size (|> r.nat (r@map (n.% 3)))] + (r.list size code^)) + composite^ (: (Random Code) + ($_ r.either + (|> multi^ (r@map code.form)) + (|> multi^ (r@map code.tuple)) + (do r.monad + [size (|> r.nat (r@map (n.% 3)))] + (|> (r.list size (r.and code^ code^)) + (r@map code.record)))))] + ($_ r.either + simple^ + composite^)))))) + +(def: code + Test + (do {@ r.monad} + [sample code^] + ($_ _.and + (_.test "Can parse Lux code." + (case (let [source-code (%.code sample)] + (/.parse "" (dictionary.new text.hash) (text.size source-code) + [default-cursor 0 source-code])) + (#.Left error) + false + + (#.Right [_ parsed]) + (:: code.equivalence = parsed sample))) + (do @ + [other code^] + (_.test "Can parse multiple Lux code nodes." + (let [source-code (format (%.code sample) " " (%.code other)) + source-code//size (text.size source-code)] + (case (/.parse "" (dictionary.new text.hash) source-code//size + [default-cursor 0 source-code]) + (#.Left error) + false + + (#.Right [remaining =sample]) + (case (/.parse "" (dictionary.new text.hash) source-code//size + remaining) + (#.Left error) + false + + (#.Right [_ =other]) + (and (:: code.equivalence = sample =sample) + (:: code.equivalence = other =other))))))) + ))) + +(def: comment-text^ + (Random Text) + (let [char-gen (|> r.nat (r.filter (|>> (n.= (`` (char (~~ (static text.new-line))))) not)))] + (do r.monad + [size (|> r.nat (r@map (n.% 20)))] + (r.text char-gen size)))) + +(def: comment^ + (Random Text) + (do r.monad + [comment comment-text^] + (wrap (format "## " comment text.new-line)))) + +(def: comments + Test + (do r.monad + [sample code^ + comment comment^] + ($_ _.and + (_.test "Can handle comments." + (case (let [source-code (format comment (%.code sample)) + source-code//size (text.size source-code)] + (/.parse "" (dictionary.new text.hash) source-code//size + [default-cursor 0 source-code])) + (#.Left error) + false + + (#.Right [_ parsed]) + (:: code.equivalence = parsed sample))) + ))) + +(def: #export test + Test + (<| (_.context (name.module (name-of /._))) + ($_ _.and + ..code + ..comments + ))) diff --git a/stdlib/source/test/lux/tool/compiler/phase/analysis.lux b/stdlib/source/test/lux/tool/compiler/phase/analysis.lux deleted file mode 100644 index 06b09fbf9..000000000 --- a/stdlib/source/test/lux/tool/compiler/phase/analysis.lux +++ /dev/null @@ -1,24 +0,0 @@ -(.module: - [lux #* - ["_" test (#+ Test)]] - ["." / #_ - ["#." primitive] - ["#." structure] - ["#." reference] - ["#." case] - ["#." function] - ["/#" // #_ - [extension - [analysis - ["#." lux]]]]]) - -(def: #export test - Test - ($_ _.and - /primitive.test - /structure.test - /reference.test - /case.test - /function.test - //lux.test - )) diff --git a/stdlib/source/test/lux/tool/compiler/phase/analysis/case.lux b/stdlib/source/test/lux/tool/compiler/phase/analysis/case.lux deleted file mode 100644 index 1ca4718c1..000000000 --- a/stdlib/source/test/lux/tool/compiler/phase/analysis/case.lux +++ /dev/null @@ -1,203 +0,0 @@ -(.module: - [lux #* - [abstract ["." monad (#+ do)]] - [data - ["%" text/format (#+ format)] - ["." name ("#@." equivalence)]] - ["r" math/random (#+ Random) ("#@." monad)] - ["_" test (#+ Test)] - [control - pipe] - [data - ["." product] - ["." maybe] - ["." text ("#@." equivalence)] - [number - ["n" nat]] - [collection - ["." list ("#@." monad)] - ["." set]]] - ["." type - ["." check]] - [macro - ["." code]]] - [// - ["_." primitive] - ["_." structure]] - {1 - ["." / - ["/#" // - ["#." module] - ["#." type] - ["/#" // - ["/#" // - ["#." analysis (#+ Analysis Variant Tag Operation)]]]]]}) - -(def: (exhaustive-weaving branchings) - (-> (List (List Code)) (List (List Code))) - (case branchings - #.Nil - #.Nil - - (#.Cons head+ #.Nil) - (list@map (|>> list) head+) - - (#.Cons head+ tail++) - (do list.monad - [tail+ (exhaustive-weaving tail++) - head head+] - (wrap (#.Cons head tail+))))) - -(def: #export (exhaustive-branches allow-literals? variantTC inputC) - (-> Bit (List [Code Code]) Code (Random (List Code))) - (case inputC - [_ (#.Bit _)] - (r@wrap (list (' #0) (' #1))) - - (^template [ ] - [_ ( _)] - (if allow-literals? - (do {@ r.monad} - [?sample (r.maybe )] - (case ?sample - (#.Some sample) - (do @ - [else (exhaustive-branches allow-literals? variantTC inputC)] - (wrap (list& ( sample) else))) - - #.None - (wrap (list (' _))))) - (r@wrap (list (' _))))) - ([#.Nat r.nat code.nat] - [#.Int r.int code.int] - [#.Rev r.rev code.rev] - [#.Frac r.frac code.frac] - [#.Text (r.unicode 5) code.text]) - - (^ [_ (#.Tuple (list))]) - (r@wrap (list (' []))) - - [_ (#.Tuple members)] - (do {@ r.monad} - [member-wise-patterns (monad.map @ (exhaustive-branches allow-literals? variantTC) members)] - (wrap (|> member-wise-patterns - exhaustive-weaving - (list@map code.tuple)))) - - (^ [_ (#.Record (list))]) - (r@wrap (list (' {}))) - - [_ (#.Record kvs)] - (do {@ r.monad} - [#let [ks (list@map product.left kvs) - vs (list@map product.right kvs)] - member-wise-patterns (monad.map @ (exhaustive-branches allow-literals? variantTC) vs)] - (wrap (|> member-wise-patterns - exhaustive-weaving - (list@map (|>> (list.zip2 ks) code.record))))) - - (^ [_ (#.Form (list [_ (#.Tag _)] _))]) - (do {@ r.monad} - [bundles (monad.map @ - (function (_ [_tag _code]) - (do @ - [v-branches (exhaustive-branches allow-literals? variantTC _code)] - (wrap (list@map (function (_ pattern) (` ((~ _tag) (~ pattern)))) - v-branches)))) - variantTC)] - (wrap (list@join bundles))) - - _ - (r@wrap (list)) - )) - -(def: #export (input variant-tags record-tags primitivesC) - (-> (List Code) (List Code) (List Code) (Random Code)) - (r.rec - (function (_ input) - ($_ r.either - (r@map product.right _primitive.primitive) - (do {@ r.monad} - [choice (|> r.nat (:: @ map (n.% (list.size variant-tags)))) - #let [choiceT (maybe.assume (list.nth choice variant-tags)) - choiceC (maybe.assume (list.nth choice primitivesC))]] - (wrap (` ((~ choiceT) (~ choiceC))))) - (do {@ r.monad} - [size (|> r.nat (:: @ map (n.% 3))) - elems (r.list size input)] - (wrap (code.tuple elems))) - (r@wrap (code.record (list.zip2 record-tags primitivesC))) - )))) - -(def: (branch body pattern) - (-> Code Code [Code Code]) - [pattern body]) - -(def: #export test - (<| (_.context (name.module (name-of /._))) - (do {@ r.monad} - [module-name (r.unicode 5) - variant-name (r.unicode 5) - record-name (|> (r.unicode 5) (r.filter (|>> (text@= variant-name) not))) - size (|> r.nat (:: @ map (|>> (n.% 10) (n.max 2)))) - variant-tags (|> (r.set text.hash size (r.unicode 5)) (:: @ map set.to-list)) - record-tags (|> (r.set text.hash size (r.unicode 5)) (:: @ map set.to-list)) - primitivesTC (r.list size _primitive.primitive) - #let [primitivesT (list@map product.left primitivesTC) - primitivesC (list@map product.right primitivesTC) - code-tag (|>> [module-name] code.tag) - variant-tags+ (list@map code-tag variant-tags) - record-tags+ (list@map code-tag record-tags) - variantTC (list.zip2 variant-tags+ primitivesC)] - inputC (input variant-tags+ record-tags+ primitivesC) - [outputT outputC] (r.filter (|>> product.left (is? Any) not) - _primitive.primitive) - #let [analyse-pm (|>> (/.case _primitive.phase inputC) - (//type.with-type outputT) - ////analysis.with-scope - (do ///.monad - [_ (//module.declare-tags variant-tags false - (#.Named [module-name variant-name] - (type.variant primitivesT))) - _ (//module.declare-tags record-tags false - (#.Named [module-name record-name] - (type.tuple primitivesT)))]) - (//module.with-module 0 module-name))] - exhaustive-patterns (exhaustive-branches true variantTC inputC) - #let [exhaustive-branchesC (list@map (branch outputC) - exhaustive-patterns)]] - ($_ _.and - (_.test "Will reject empty pattern-matching (no branches)." - (|> (analyse-pm (list)) - _structure.check-fails)) - (_.test "Can analyse exhaustive pattern-matching." - (|> (analyse-pm exhaustive-branchesC) - _structure.check-succeeds)) - (let [non-exhaustive-branchesC (list.take (dec (list.size exhaustive-branchesC)) - exhaustive-branchesC)] - (_.test "Will reject non-exhaustive pattern-matching." - (|> (analyse-pm non-exhaustive-branchesC) - _structure.check-fails))) - (do @ - [redundant-patterns (exhaustive-branches false variantTC inputC) - redundancy-idx (|> r.nat (:: @ map (n.% (list.size redundant-patterns)))) - #let [redundant-branchesC (<| (list@map (branch outputC)) - list.concat - (list (list.take redundancy-idx redundant-patterns) - (list (maybe.assume (list.nth redundancy-idx redundant-patterns))) - (list.drop redundancy-idx redundant-patterns)))]] - (_.test "Will reject redundant pattern-matching." - (|> (analyse-pm redundant-branchesC) - _structure.check-fails))) - (do @ - [[heterogeneousT heterogeneousC] (r.filter (|>> product.left (check.checks? outputT) not) - _primitive.primitive) - heterogeneous-idx (|> r.nat (:: @ map (n.% (list.size exhaustive-patterns)))) - #let [heterogeneous-branchesC (list.concat (list (list.take heterogeneous-idx exhaustive-branchesC) - (list (let [[_pattern _body] (maybe.assume (list.nth heterogeneous-idx exhaustive-branchesC))] - [_pattern heterogeneousC])) - (list.drop (inc heterogeneous-idx) exhaustive-branchesC)))]] - (_.test "Will reject pattern-matching if the bodies of the branches do not all have the same type." - (|> (analyse-pm heterogeneous-branchesC) - _structure.check-fails))) - )))) diff --git a/stdlib/source/test/lux/tool/compiler/phase/analysis/function.lux b/stdlib/source/test/lux/tool/compiler/phase/analysis/function.lux deleted file mode 100644 index fc07f8963..000000000 --- a/stdlib/source/test/lux/tool/compiler/phase/analysis/function.lux +++ /dev/null @@ -1,127 +0,0 @@ -(.module: - [lux #* - [abstract ["." monad (#+ do)]] - [data - ["%" text/format (#+ format)] - ["." name ("#@." equivalence)]] - ["r" math/random (#+ Random) ("#@." monad)] - ["_" test (#+ Test)] - [control - pipe - ["." try]] - [data - ["." maybe] - ["." product] - ["." text ("#@." equivalence)] - [number - ["n" nat]] - [collection - ["." list ("#@." functor)]]] - ["." type] - ["." macro - ["." code]]] - [// - ["_." primitive] - ["_." structure]] - {1 - ["." / - ["/#" // - ["#." module] - ["#." type] - ["/#" // - ["/#" // - ["#." reference] - ["#." analysis (#+ Analysis Operation)]]]]]}) - -(def: (check-apply expectedT num-args analysis) - (-> Type Nat (Operation Analysis) Bit) - (|> analysis - (//type.with-type expectedT) - (///.run _primitive.state) - (case> (#try.Success applyA) - (let [[funcA argsA] (////analysis.application applyA)] - (n.= num-args (list.size argsA))) - - (#try.Failure _) - false))) - -(def: abstraction - (do r.monad - [func-name (r.unicode 5) - arg-name (|> (r.unicode 5) (r.filter (|>> (text@= func-name) not))) - [outputT outputC] _primitive.primitive - [inputT _] _primitive.primitive - #let [g!arg (code.local-identifier arg-name)]] - (<| (_.context (%.name (name-of /.function))) - ($_ _.and - (_.test "Can analyse function." - (and (|> (//type.with-type (All [a] (-> a outputT)) - (/.function _primitive.phase func-name arg-name outputC)) - _structure.check-succeeds) - (|> (//type.with-type (All [a] (-> a a)) - (/.function _primitive.phase func-name arg-name g!arg)) - _structure.check-succeeds))) - (_.test "Generic functions can always be specialized." - (and (|> (//type.with-type (-> inputT outputT) - (/.function _primitive.phase func-name arg-name outputC)) - _structure.check-succeeds) - (|> (//type.with-type (-> inputT inputT) - (/.function _primitive.phase func-name arg-name g!arg)) - _structure.check-succeeds))) - (_.test "The function's name is bound to the function's type." - (|> (//type.with-type (Rec self (-> inputT self)) - (/.function _primitive.phase func-name arg-name (code.local-identifier func-name))) - _structure.check-succeeds)) - )))) - -(def: apply - (do {@ r.monad} - [full-args (|> r.nat (:: @ map (|>> (n.% 10) (n.max 2)))) - partial-args (|> r.nat (:: @ map (n.% full-args))) - var-idx (|> r.nat (:: @ map (|>> (n.% full-args) (n.max 1)))) - inputsTC (r.list full-args _primitive.primitive) - #let [inputsT (list@map product.left inputsTC) - inputsC (list@map product.right inputsTC)] - [outputT outputC] _primitive.primitive - #let [funcT (type.function inputsT outputT) - partialT (type.function (list.drop partial-args inputsT) outputT) - varT (#.Parameter 1) - polyT (<| (type.univ-q 1) - (type.function (list.concat (list (list.take var-idx inputsT) - (list varT) - (list.drop (inc var-idx) inputsT)))) - varT) - poly-inputT (maybe.assume (list.nth var-idx inputsT)) - partial-poly-inputsT (list.drop (inc var-idx) inputsT) - partial-polyT1 (<| (type.function partial-poly-inputsT) - poly-inputT) - partial-polyT2 (<| (type.univ-q 1) - (type.function (#.Cons varT partial-poly-inputsT)) - varT) - dummy-function (#////analysis.Function (list) (#////analysis.Reference (////reference.local 1)))]] - (<| (_.context (%.name (name-of /.apply))) - ($_ _.and - (_.test "Can analyse monomorphic type application." - (|> (/.apply _primitive.phase funcT dummy-function (' []) inputsC) - (check-apply outputT full-args))) - (_.test "Can partially apply functions." - (|> (/.apply _primitive.phase funcT dummy-function (' []) (list.take partial-args inputsC)) - (check-apply partialT partial-args))) - (_.test "Can apply polymorphic functions." - (|> (/.apply _primitive.phase polyT dummy-function (' []) inputsC) - (check-apply poly-inputT full-args))) - (_.test "Polymorphic partial application propagates found type-vars." - (|> (/.apply _primitive.phase polyT dummy-function (' []) (list.take (inc var-idx) inputsC)) - (check-apply partial-polyT1 (inc var-idx)))) - (_.test "Polymorphic partial application preserves quantification for type-vars." - (|> (/.apply _primitive.phase polyT dummy-function (' []) (list.take var-idx inputsC)) - (check-apply partial-polyT2 var-idx))) - )))) - -(def: #export test - Test - (<| (_.context (name.module (name-of /._))) - ($_ _.and - ..abstraction - ..apply - ))) diff --git a/stdlib/source/test/lux/tool/compiler/phase/analysis/primitive.lux b/stdlib/source/test/lux/tool/compiler/phase/analysis/primitive.lux deleted file mode 100644 index 57c3152d9..000000000 --- a/stdlib/source/test/lux/tool/compiler/phase/analysis/primitive.lux +++ /dev/null @@ -1,110 +0,0 @@ -(.module: - [lux (#- primitive) - ["@" target] - [abstract ["." monad (#+ do)]] - [data - ["%" text/format (#+ format)] - ["." name]] - ["r" math/random (#+ Random) ("#@." monad)] - ["_" test (#+ Test)] - [control - pipe - ["." try (#+ Try)] - ["." exception (#+ exception:)]] - ["." type ("#@." equivalence)] - [macro - ["." code]]] - {1 - ["." / - ["/#" // - ["#." type] - ["/#" // - [macro (#+ Expander)] - [extension - ["." bundle] - ["#." analysis]] - ["/#" // - ["#." analysis (#+ Analysis Operation)] - [default - [evaluation (#+ Eval)] - ["." init]]]]]]}) - -(def: #export (expander macro inputs state) - Expander - (#try.Failure "NOPE")) - -(def: #export (eval count type expression) - Eval - (function (_ state) - (#try.Failure "NO!"))) - -(def: #export phase - ////analysis.Phase - (//.phase ..expander)) - -(def: #export state - ////analysis.State+ - [(///analysis.bundle ..eval bundle.empty) - (////analysis.state (init.info @.jvm) [])]) - -(def: #export primitive - (Random [Type Code]) - (`` ($_ r.either - (~~ (template [ ] - [(r.and (r@wrap ) (r@map ))] - - [Any code.tuple (r.list 0 (r@wrap (' [])))] - [Bit code.bit r.bit] - [Nat code.nat r.nat] - [Int code.int r.int] - [Rev code.rev r.rev] - [Frac code.frac r.frac] - [Text code.text (r.unicode 5)] - ))))) - -(exception: (wrong-inference {expected Type} {inferred Type}) - (exception.report - ["Expected" (%.type expected)] - ["Inferred" (%.type inferred)])) - -(def: (infer expected-type analysis) - (-> Type (Operation Analysis) (Try Analysis)) - (|> analysis - //type.with-inference - (///.run ..state) - (case> (#try.Success [inferred-type output]) - (if (is? expected-type inferred-type) - (#try.Success output) - (exception.throw wrong-inference [expected-type inferred-type])) - - (#try.Failure error) - (#try.Failure error)))) - -(def: #export test - (<| (_.context (name.module (name-of /._))) - (`` ($_ _.and - (_.test (%.name (name-of #////analysis.Unit)) - (|> (infer Any (..phase (' []))) - (case> (^ (#try.Success (#////analysis.Primitive (#////analysis.Unit output)))) - (is? [] output) - - _ - false))) - (~~ (template [ ] - [(do r.monad - [sample ] - (_.test (%.name (name-of )) - (|> (infer (..phase ( sample))) - (case> (#try.Success (#////analysis.Primitive ( output))) - (is? sample output) - - _ - false))))] - - [Bit #////analysis.Bit r.bit code.bit] - [Nat #////analysis.Nat r.nat code.nat] - [Int #////analysis.Int r.int code.int] - [Rev #////analysis.Rev r.rev code.rev] - [Frac #////analysis.Frac r.frac code.frac] - [Text #////analysis.Text (r.unicode 5) code.text] - )))))) diff --git a/stdlib/source/test/lux/tool/compiler/phase/analysis/reference.lux b/stdlib/source/test/lux/tool/compiler/phase/analysis/reference.lux deleted file mode 100644 index 9cb0c1170..000000000 --- a/stdlib/source/test/lux/tool/compiler/phase/analysis/reference.lux +++ /dev/null @@ -1,103 +0,0 @@ -(.module: - [lux #* - [abstract ["." monad (#+ do)]] - [data - ["." name ("#@." equivalence)]] - ["r" math/random (#+ Random) ("#@." monad)] - ["_" test (#+ Test)] - [control - pipe - ["." try (#+ Try)]] - [data - ["." text ("#@." equivalence)] - [number - ["n" nat]]] - ["." type ("#@." equivalence)] - [macro - ["." code]]] - [// - ["_." primitive]] - {1 - ["." / - ["/#" // - ["#." scope] - ["#." module] - ["#." type] - ["/#" // - ["/#" // - ["#." reference] - ["#." analysis (#+ Analysis Variant Tag Operation)]]]]]}) - -(type: Check (-> (Try Any) Bit)) - -(template [ ] - [(def: - Check - (|>> (case> (#try.Success _) - - - (#try.Failure _) - )))] - - [success? true false] - [failure? false true] - ) - -(def: (reach-test var-name [export? def-module] [import? dependent-module] check!) - (-> Text [Bit Text] [Bit Text] Check Bit) - (|> (do {@ ///.monad} - [_ (//module.with-module 0 def-module - (//module.define var-name (#.Right [export? Any (' {}) []])))] - (//module.with-module 0 dependent-module - (do @ - [_ (if import? - (//module.import def-module) - (wrap []))] - (//type.with-inference - (_primitive.phase (code.identifier [def-module var-name])))))) - (///.run _primitive.state) - check!)) - -(def: #export test - (<| (_.context (name.module (name-of /._))) - (do r.monad - [[expectedT _] _primitive.primitive - def-module (r.unicode 5) - scope-name (r.unicode 5) - var-name (r.unicode 5) - dependent-module (|> (r.unicode 5) - (r.filter (|>> (text@= def-module) not)))] - ($_ _.and - (_.test "Can analyse variable." - (|> (//scope.with-scope scope-name - (//scope.with-local [var-name expectedT] - (//type.with-inference - (_primitive.phase (code.local-identifier var-name))))) - (///.run _primitive.state) - (case> (^ (#try.Success [inferredT (#////analysis.Reference (////reference.local var))])) - (and (type@= expectedT inferredT) - (n.= 0 var)) - - _ - false))) - (_.test "Can analyse definition (in the same module)." - (let [def-name [def-module var-name]] - (|> (do ///.monad - [_ (//module.define var-name (#.Right [false expectedT (' {}) []]))] - (//type.with-inference - (_primitive.phase (code.identifier def-name)))) - (//module.with-module 0 def-module) - (///.run _primitive.state) - (case> (^ (#try.Success [_ inferredT (#////analysis.Reference (////reference.constant constant-name))])) - (and (type@= expectedT inferredT) - (name@= def-name constant-name)) - - _ - false)))) - (_.test "Can analyse definition (if exported from imported module)." - (reach-test var-name [true def-module] [true dependent-module] success?)) - (_.test "Cannot analyse definition (if not exported from imported module)." - (reach-test var-name [false def-module] [true dependent-module] failure?)) - (_.test "Cannot analyse definition (if exported from non-imported module)." - (reach-test var-name [true def-module] [false dependent-module] failure?)) - )))) diff --git a/stdlib/source/test/lux/tool/compiler/phase/analysis/structure.lux b/stdlib/source/test/lux/tool/compiler/phase/analysis/structure.lux deleted file mode 100644 index 05461adf6..000000000 --- a/stdlib/source/test/lux/tool/compiler/phase/analysis/structure.lux +++ /dev/null @@ -1,305 +0,0 @@ -(.module: - [lux #* - [abstract ["." monad (#+ do)]] - [data - ["%" text/format (#+ format)] - ["." name]] - ["r" math/random (#+ Random) ("#@." monad)] - ["_" test (#+ Test)] - [control - pipe - ["." try]] - [data - ["." bit ("#@." equivalence)] - ["." product] - ["." maybe] - ["." text] - [number - ["n" nat]] - [collection - ["." list ("#@." functor)] - ["." set]]] - ["." type - ["." check]] - [macro - ["." code]]] - [// - ["_." primitive]] - {1 - ["." / - ["/#" // - ["#." module] - ["#." type] - ["/#" // - ["/#" // - ["#." analysis (#+ Analysis Variant Tag Operation)]]]]]}) - -(template [ ] - [(def: #export - (All [a] (-> (Operation a) Bit)) - (|>> (///.run _primitive.state) - (case> (#try.Success _) - - - _ - )))] - - [check-succeeds true false] - [check-fails false true] - ) - -(def: (check-sum' tag size variant) - (-> Tag Nat (Variant Analysis) Bit) - (let [expected//right? (n.= (dec size) tag) - expected//lefts (if expected//right? - (dec tag) - tag) - actual//right? (get@ #////analysis.right? variant) - actual//lefts (get@ #////analysis.lefts variant)] - (and (n.= expected//lefts - actual//lefts) - (bit@= expected//right? - actual//right?)))) - -(def: (check-sum type tag size analysis) - (-> Type Tag Nat (Operation Analysis) Bit) - (|> analysis - (//type.with-type type) - (///.run _primitive.state) - (case> (^ (#try.Success (////analysis.variant variant))) - (check-sum' tag size variant) - - _ - false))) - -(def: (with-tags module tags type) - (All [a] (-> Text (List //module.Tag) Type (Operation a) (Operation [Module a]))) - (|>> (do ///.monad - [_ (//module.declare-tags tags false type)]) - (//module.with-module 0 module))) - -(def: (check-variant module tags expectedT variantT tag analysis) - (-> Text (List //module.Tag) Type Type Tag (Operation Analysis) Bit) - (|> analysis - (with-tags module tags variantT) - (//type.with-type expectedT) - (///.run _primitive.state) - (case> (^ (#try.Success [_ (////analysis.variant variant)])) - (check-sum' tag (list.size tags) variant) - - _ - false))) - -(def: (correct-size? size) - (-> Nat (-> Analysis Bit)) - (|>> (case> (^ (////analysis.tuple elems)) - (|> elems - list.size - (n.= size)) - - _ - false))) - -(def: (check-record module tags expectedT recordT size analysis) - (-> Text (List //module.Tag) Type Type Nat (Operation Analysis) Bit) - (|> analysis - (with-tags module tags recordT) - (//type.with-type expectedT) - (///.run _primitive.state) - (case> (#try.Success [_ productA]) - (correct-size? size productA) - - _ - false))) - -(def: sum - (do {@ r.monad} - [size (|> r.nat (:: @ map (|>> (n.% 10) (n.max 2)))) - choice (|> r.nat (:: @ map (n.% size))) - primitives (r.list size _primitive.primitive) - +choice (|> r.nat (:: @ map (n.% (inc size)))) - [_ +valueC] _primitive.primitive - #let [variantT (type.variant (list@map product.left primitives)) - [valueT valueC] (maybe.assume (list.nth choice primitives)) - +size (inc size) - +primitives (list.concat (list (list.take choice primitives) - (list [(#.Parameter 1) +valueC]) - (list.drop choice primitives))) - [+valueT +valueC] (maybe.assume (list.nth +choice +primitives)) - +variantT (type.variant (list@map product.left +primitives))]] - (<| (_.context (%.name (name-of /.sum))) - ($_ _.and - (_.test "Can analyse." - (check-sum variantT choice size - (/.sum _primitive.phase choice valueC))) - (_.test "Can analyse through bound type-vars." - (|> (do ///.monad - [[_ varT] (//type.with-env check.var) - _ (//type.with-env - (check.check varT variantT))] - (//type.with-type varT - (/.sum _primitive.phase choice valueC))) - (///.run _primitive.state) - (case> (^ (#try.Success (////analysis.variant variant))) - (check-sum' choice size variant) - - _ - false))) - (_.test "Cannot analyse through unbound type-vars." - (|> (do ///.monad - [[_ varT] (//type.with-env check.var)] - (//type.with-type varT - (/.sum _primitive.phase choice valueC))) - check-fails)) - (_.test "Can analyse through existential quantification." - (|> (//type.with-type (type.ex-q 1 +variantT) - (/.sum _primitive.phase +choice +valueC)) - check-succeeds)) - (_.test "Can analyse through universal quantification." - (let [check-outcome (if (not (n.= choice +choice)) - check-succeeds - check-fails)] - (|> (//type.with-type (type.univ-q 1 +variantT) - (/.sum _primitive.phase +choice +valueC)) - check-outcome))) - )))) - -(def: product - (do {@ r.monad} - [size (|> r.nat (:: @ map (|>> (n.% 10) (n.max 2)))) - primitives (r.list size _primitive.primitive) - choice (|> r.nat (:: @ map (n.% size))) - [_ +valueC] _primitive.primitive - #let [tupleT (type.tuple (list@map product.left primitives)) - [singletonT singletonC] (|> primitives (list.nth choice) maybe.assume) - +primitives (list.concat (list (list.take choice primitives) - (list [(#.Parameter 1) +valueC]) - (list.drop choice primitives))) - +tupleT (type.tuple (list@map product.left +primitives))]] - (<| (_.context (%.name (name-of /.product))) - ($_ _.and - (_.test "Can analyse." - (|> (//type.with-type tupleT - (/.product _primitive.phase (list@map product.right primitives))) - (///.run _primitive.state) - (case> (#try.Success tupleA) - (correct-size? size tupleA) - - _ - false))) - (_.test "Can infer." - (|> (//type.with-inference - (/.product _primitive.phase (list@map product.right primitives))) - (///.run _primitive.state) - (case> (#try.Success [_type tupleA]) - (and (check.checks? tupleT _type) - (correct-size? size tupleA)) - - _ - false))) - (_.test "Can analyse singleton." - (|> (//type.with-type singletonT - (_primitive.phase (` [(~ singletonC)]))) - check-succeeds)) - (_.test "Can analyse through bound type-vars." - (|> (do ///.monad - [[_ varT] (//type.with-env check.var) - _ (//type.with-env - (check.check varT (type.tuple (list@map product.left primitives))))] - (//type.with-type varT - (/.product _primitive.phase (list@map product.right primitives)))) - (///.run _primitive.state) - (case> (#try.Success tupleA) - (correct-size? size tupleA) - - _ - false))) - (_.test "Can analyse through existential quantification." - (|> (//type.with-type (type.ex-q 1 +tupleT) - (/.product _primitive.phase (list@map product.right +primitives))) - check-succeeds)) - (_.test "Cannot analyse through universal quantification." - (|> (//type.with-type (type.univ-q 1 +tupleT) - (/.product _primitive.phase (list@map product.right +primitives))) - check-fails)) - )))) - -(def: variant - (do {@ r.monad} - [size (|> r.nat (:: @ map (|>> (n.% 10) (n.max 2)))) - tags (|> (r.set text.hash size (r.unicode 5)) (:: @ map set.to-list)) - choice (|> r.nat (:: @ map (n.% size))) - other-choice (|> r.nat (:: @ map (n.% size)) (r.filter (|>> (n.= choice) not))) - primitives (r.list size _primitive.primitive) - module-name (r.unicode 5) - type-name (r.unicode 5) - #let [with-name (|>> (#.Named [module-name type-name])) - varT (#.Parameter 1) - primitivesT (list@map product.left primitives) - [choiceT choiceC] (maybe.assume (list.nth choice primitives)) - [other-choiceT other-choiceC] (maybe.assume (list.nth other-choice primitives)) - monoT (type.variant primitivesT) - polyT (|> (type.variant (list.concat (list (list.take choice primitivesT) - (list varT) - (list.drop (inc choice) primitivesT)))) - (type.univ-q 1)) - choice-tag (maybe.assume (list.nth choice tags)) - other-choice-tag (maybe.assume (list.nth other-choice tags))]] - (<| (_.context (%.name (name-of /.tagged-sum))) - ($_ _.and - (_.test "Can infer." - (|> (/.tagged-sum _primitive.phase [module-name choice-tag] choiceC) - (check-variant module-name tags - monoT (with-name monoT) - choice))) - (_.test "Inference retains universal quantification when type-vars are not bound." - (|> (/.tagged-sum _primitive.phase [module-name other-choice-tag] other-choiceC) - (check-variant module-name tags - polyT (with-name polyT) - other-choice))) - (_.test "Can specialize." - (|> (//type.with-type monoT - (/.tagged-sum _primitive.phase [module-name other-choice-tag] other-choiceC)) - (check-variant module-name tags - monoT (with-name polyT) - other-choice))) - (_.test "Specialization when type-vars get bound." - (|> (/.tagged-sum _primitive.phase [module-name choice-tag] choiceC) - (check-variant module-name tags - monoT (with-name polyT) - choice))) - )))) - -(def: record - (do {@ r.monad} - [size (|> r.nat (:: @ map (|>> (n.% 10) (n.max 2)))) - tags (|> (r.set text.hash size (r.unicode 5)) (:: @ map set.to-list)) - primitives (r.list size _primitive.primitive) - module-name (r.unicode 5) - type-name (r.unicode 5) - choice (|> r.nat (:: @ map (n.% size))) - #let [varT (#.Parameter 1) - tagsC (list@map (|>> [module-name] code.tag) tags) - primitivesT (list@map product.left primitives) - primitivesC (list@map product.right primitives) - monoT (#.Named [module-name type-name] (type.tuple primitivesT)) - recordC (list.zip2 tagsC primitivesC) - polyT (|> (type.tuple (list.concat (list (list.take choice primitivesT) - (list varT) - (list.drop (inc choice) primitivesT)))) - (type.univ-q 1) - (#.Named [module-name type-name]))]] - (<| (_.context (%.name (name-of /.record))) - (_.test "Can infer." - (|> (/.record _primitive.phase recordC) - (check-record module-name tags monoT monoT size)))))) - -(def: #export test - Test - (<| (_.context (name.module (name-of /._))) - ($_ _.and - ..sum - ..product - ..variant - ..record - ))) diff --git a/stdlib/source/test/lux/tool/compiler/phase/extension/analysis/lux.lux b/stdlib/source/test/lux/tool/compiler/phase/extension/analysis/lux.lux deleted file mode 100644 index df4e5a7e5..000000000 --- a/stdlib/source/test/lux/tool/compiler/phase/extension/analysis/lux.lux +++ /dev/null @@ -1,201 +0,0 @@ -(.module: - [lux (#- i64 int primitive) - [abstract ["." monad (#+ do)]] - [data - ["%" text/format (#+ format)] - ["." name]] - ["r" math/random (#+ Random) ("#@." monad)] - ["_" test (#+ Test)] - [control - pipe - [io (#+ IO)] - ["." try] - [concurrency - ["." atom]]] - [data - ["." product]] - ["." type ("#@." equivalence)] - [macro - ["." code]]] - [//// - [analysis - ["_." primitive]]] - {1 - ["." / - ["///#" //// - [analysis - ["#." scope] - ["#." type]]]]}) - -(template [ ] - [(def: ( procedure params output-type) - (-> Text (List Code) Type Bit) - (|> (////scope.with-scope "" - (////type.with-type output-type - (_primitive.phase (` ((~ (code.text procedure)) (~+ params)))))) - (////.run _primitive.state) - (case> (#try.Success _) - - - (#try.Failure _) - )))] - - [check-success+ true false] - [check-failure+ false true] - ) - -(def: primitive - (Random [Type Code]) - (r.filter (|>> product.left (is? Any) not) _primitive.primitive)) - -(def: lux - Test - (do r.monad - [[primT primC] ..primitive - [antiT antiC] (|> ..primitive - (r.filter (|>> product.left (type@= primT) not)))] - ($_ _.and - (_.test "Can test for reference equality." - (check-success+ "lux is" (list primC primC) Bit)) - (_.test "Reference equality must be done with elements of the same type." - (check-failure+ "lux is" (list primC antiC) Bit)) - (_.test "Can 'try' risky IO computations." - (check-success+ "lux try" - (list (` ("lux io error" "YOLO"))) - (type (Either Text primT)))) - ))) - -(def: i64 - Test - (do {@ r.monad} - [subjectC (|> r.nat (:: @ map code.nat)) - signedC (|> r.int (:: @ map code.int)) - paramC (|> r.nat (:: @ map code.nat))] - ($_ _.and - (_.test "i64 'and'." - (check-success+ "lux i64 and" (list paramC subjectC) Nat)) - (_.test "i64 'or'." - (check-success+ "lux i64 or" (list paramC subjectC) Nat)) - (_.test "i64 'xor'." - (check-success+ "lux i64 xor" (list paramC subjectC) Nat)) - (_.test "i64 left-shift." - (check-success+ "lux i64 left-shift" (list paramC subjectC) Nat)) - (_.test "i64 logical-right-shift." - (check-success+ "lux i64 logical-right-shift" (list paramC subjectC) Nat)) - (_.test "i64 arithmetic-right-shift." - (check-success+ "lux i64 arithmetic-right-shift" (list paramC signedC) Int)) - (_.test "i64 equivalence." - (check-success+ "lux i64 =" (list paramC subjectC) Bit)) - (_.test "i64 addition." - (check-success+ "lux i64 +" (list paramC subjectC) Int)) - (_.test "i64 subtraction." - (check-success+ "lux i64 -" (list paramC subjectC) Int)) - ))) - -(def: int - Test - (do {@ r.monad} - [subjectC (|> r.int (:: @ map code.int)) - paramC (|> r.int (:: @ map code.int))] - ($_ _.and - (_.test "Can multiply integers." - (check-success+ "lux i64 *" (list paramC subjectC) Int)) - (_.test "Can divide integers." - (check-success+ "lux i64 /" (list paramC subjectC) Int)) - (_.test "Can calculate remainder of integers." - (check-success+ "lux i64 %" (list paramC subjectC) Int)) - (_.test "Can compare integers." - (check-success+ "lux i64 <" (list paramC subjectC) Bit)) - (_.test "Can convert integer to text." - (check-success+ "lux i64 char" (list subjectC) Text)) - (_.test "Can convert integer to fraction." - (check-success+ "lux i64 f64" (list subjectC) Frac)) - ))) - -(def: frac - Test - (do {@ r.monad} - [subjectC (|> r.safe-frac (:: @ map code.frac)) - paramC (|> r.safe-frac (:: @ map code.frac)) - encodedC (|> r.safe-frac (:: @ map (|>> %.frac code.text)))] - ($_ _.and - (_.test "Can add frac numbers." - (check-success+ "lux f64 +" (list paramC subjectC) Frac)) - (_.test "Can subtract frac numbers." - (check-success+ "lux f64 -" (list paramC subjectC) Frac)) - (_.test "Can multiply frac numbers." - (check-success+ "lux f64 *" (list paramC subjectC) Frac)) - (_.test "Can divide frac numbers." - (check-success+ "lux f64 /" (list paramC subjectC) Frac)) - (_.test "Can calculate remainder of frac numbers." - (check-success+ "lux f64 %" (list paramC subjectC) Frac)) - (_.test "Can test equivalence of frac numbers." - (check-success+ "lux f64 =" (list paramC subjectC) Bit)) - (_.test "Can compare frac numbers." - (check-success+ "lux f64 <" (list paramC subjectC) Bit)) - (_.test "Can obtain minimum frac number." - (check-success+ "lux f64 min" (list) Frac)) - (_.test "Can obtain maximum frac number." - (check-success+ "lux f64 max" (list) Frac)) - (_.test "Can obtain smallest frac number." - (check-success+ "lux f64 smallest" (list) Frac)) - (_.test "Can convert frac number to integer." - (check-success+ "lux f64 i64" (list subjectC) Int)) - (_.test "Can convert frac number to text." - (check-success+ "lux f64 encode" (list subjectC) Text)) - (_.test "Can convert text to frac number." - (check-success+ "lux f64 decode" (list encodedC) (type (Maybe Frac)))) - ))) - -(def: text - Test - (do {@ r.monad} - [subjectC (|> (r.unicode 5) (:: @ map code.text)) - paramC (|> (r.unicode 5) (:: @ map code.text)) - replacementC (|> (r.unicode 5) (:: @ map code.text)) - fromC (|> r.nat (:: @ map code.nat)) - toC (|> r.nat (:: @ map code.nat))] - ($_ _.and - (_.test "Can test text equivalence." - (check-success+ "lux text =" (list paramC subjectC) Bit)) - (_.test "Compare texts in lexicographical order." - (check-success+ "lux text <" (list paramC subjectC) Bit)) - (_.test "Can concatenate one text to another." - (check-success+ "lux text concat" (list subjectC paramC) Text)) - (_.test "Can find the index of a piece of text inside a larger one that (may) contain it." - (check-success+ "lux text index" (list fromC paramC subjectC) (type (Maybe Nat)))) - (_.test "Can query the size/length of a text." - (check-success+ "lux text size" (list subjectC) Nat)) - (_.test "Can obtain the character code of a text at a given index." - (check-success+ "lux text char" (list fromC subjectC) Nat)) - (_.test "Can clip a piece of text between 2 indices." - (check-success+ "lux text clip" (list fromC toC subjectC) Text)) - ))) - -(def: io - Test - (do {@ r.monad} - [logC (|> (r.unicode 5) (:: @ map code.text)) - exitC (|> r.int (:: @ map code.int))] - ($_ _.and - (_.test "Can log messages to standard output." - (check-success+ "lux io log" (list logC) Any)) - (_.test "Can throw a run-time error." - (check-success+ "lux io error" (list logC) Nothing)) - (_.test "Can exit the program." - (check-success+ "lux io exit" (list exitC) Nothing)) - (_.test "Can query the current time (as milliseconds since epoch)." - (check-success+ "lux io current-time" (list) Int)) - ))) - -(def: #export test - Test - (<| (_.context (name.module (name-of /._))) - ($_ _.and - ..lux - ..i64 - ..int - ..frac - ..text - ..io - ))) diff --git a/stdlib/source/test/lux/tool/compiler/phase/synthesis.lux b/stdlib/source/test/lux/tool/compiler/phase/synthesis.lux deleted file mode 100644 index da9937862..000000000 --- a/stdlib/source/test/lux/tool/compiler/phase/synthesis.lux +++ /dev/null @@ -1,17 +0,0 @@ -(.module: - [lux #* - ["_" test (#+ Test)]] - ["." / #_ - ["#." primitive] - ["#." structure] - ["#." case] - ["#." function]]) - -(def: #export test - Test - ($_ _.and - /primitive.test - /structure.test - /case.test - /function.test - )) diff --git a/stdlib/source/test/lux/tool/compiler/phase/synthesis/case.lux b/stdlib/source/test/lux/tool/compiler/phase/synthesis/case.lux deleted file mode 100644 index 263f5e4a7..000000000 --- a/stdlib/source/test/lux/tool/compiler/phase/synthesis/case.lux +++ /dev/null @@ -1,101 +0,0 @@ -(.module: - [lux #* - [abstract ["." monad (#+ do)]] - [data - ["." name] - [number - ["n" nat]]] - ["r" math/random (#+ Random) ("#@." monad)] - ["_" test (#+ Test)] - [control - pipe - ["." try ("#@." functor)]]] - ["." // #_ - ["#." primitive]] - {1 - ["." / - ["/#" // - ["/#" // - [extension - ["#." bundle]] - ["/#" // - ["#." reference] - ["#." analysis (#+ Branch Analysis)] - ["#." synthesis (#+ Synthesis)]]]]]}) - -(def: dummy-vars - Test - (do {@ r.monad} - [maskedA //primitive.primitive - temp (|> r.nat (:: @ map (n.% 100))) - #let [maskA (////analysis.control/case - [maskedA - [[(#////analysis.Bind temp) - (#////analysis.Reference (////reference.local temp))] - (list)]])]] - (_.test "Dummy variables created to mask expressions get eliminated during synthesis." - (|> maskA - //.phase - (///.run [///bundle.empty ////synthesis.init]) - (try@map (//primitive.corresponds? maskedA)) - (try.default false))))) - -(def: let-expr - Test - (do r.monad - [registerA r.nat - inputA //primitive.primitive - outputA //primitive.primitive - #let [letA (////analysis.control/case - [inputA - [[(#////analysis.Bind registerA) - outputA] - (list)]])]] - (_.test "Can detect and reify simple 'let' expressions." - (|> letA - //.phase - (///.run [///bundle.empty ////synthesis.init]) - (case> (^ (#try.Success (////synthesis.branch/let [inputS registerS outputS]))) - (and (n.= registerA registerS) - (//primitive.corresponds? inputA inputS) - (//primitive.corresponds? outputA outputS)) - - _ - false))))) - -(def: if-expr - Test - (do r.monad - [then|else r.bit - inputA //primitive.primitive - thenA //primitive.primitive - elseA //primitive.primitive - #let [thenB (: Branch - [(#////analysis.Simple (#////analysis.Bit true)) - thenA]) - elseB (: Branch - [(#////analysis.Simple (#////analysis.Bit false)) - elseA]) - ifA (if then|else - (////analysis.control/case [inputA [thenB (list elseB)]]) - (////analysis.control/case [inputA [elseB (list thenB)]]))]] - (_.test "Can detect and reify simple 'if' expressions." - (|> ifA - //.phase - (///.run [///bundle.empty ////synthesis.init]) - (case> (^ (#try.Success (////synthesis.branch/if [inputS thenS elseS]))) - (and (//primitive.corresponds? inputA inputS) - (//primitive.corresponds? thenA thenS) - (//primitive.corresponds? elseA elseS)) - - _ - false))))) - -(def: #export test - Test - (<| (_.context (name.module (name-of /._))) - ($_ _.and - ..dummy-vars - ..let-expr - ..if-expr - ))) diff --git a/stdlib/source/test/lux/tool/compiler/phase/synthesis/function.lux b/stdlib/source/test/lux/tool/compiler/phase/synthesis/function.lux deleted file mode 100644 index 1a4993c92..000000000 --- a/stdlib/source/test/lux/tool/compiler/phase/synthesis/function.lux +++ /dev/null @@ -1,185 +0,0 @@ -(.module: - [lux #* - [abstract ["." monad (#+ do)]] - [data - ["." name]] - ["r" math/random (#+ Random) ("#@." monad)] - ["_" test (#+ Test)] - [control - pipe - ["." try]] - [data - ["." product] - ["." maybe] - [number - ["n" nat]] - [collection - ["." list ("#@." functor fold)] - ["dict" dictionary (#+ Dictionary)] - ["." set]]]] - ["." // #_ - ["#." primitive]] - {1 - ["." / - ["/#" // - ["/#" // - [extension - ["#." bundle]] - ["/#" // - [arity (#+ Arity)] - ["#." reference (#+ Variable) ("variable@." equivalence)] - ["#." analysis (#+ Analysis)] - ["#." synthesis (#+ Synthesis)]]]]]}) - -(def: constant-function - (Random [Arity Analysis Analysis]) - (r.rec - (function (_ constant-function) - (do {@ r.monad} - [function? r.bit] - (if function? - (do @ - [[arity bodyA predictionA] constant-function] - (wrap [(inc arity) - (#////analysis.Function (list) bodyA) - predictionA])) - (do @ - [predictionA //primitive.primitive] - (wrap [0 predictionA predictionA]))))))) - -(def: (pick scope-size) - (-> Nat (Random Nat)) - (|> r.nat (:: r.monad map (n.% scope-size)))) - -(def: function-with-environment - (Random [Arity Analysis Variable]) - (do {@ r.monad} - [num-locals (|> r.nat (:: @ map (|>> (n.% 100) (n.max 10)))) - #let [indices (list.n/range 0 (dec num-locals)) - local-env (list@map (|>> #////reference.Local) indices) - foreign-env (list@map (|>> #////reference.Foreign) indices)] - [arity bodyA predictionA] (: (Random [Arity Analysis Variable]) - (loop [arity 1 - current-env foreign-env] - (let [current-env/size (list.size current-env) - resolver (list@fold (function (_ [idx var] resolver) - (dict.put idx var resolver)) - (: (Dictionary Nat Variable) - (dict.new n.hash)) - (list.enumerate current-env))] - (do @ - [nest? r.bit] - (if nest? - (do @ - [num-picks (:: @ map (n.max 1) (pick (inc current-env/size))) - picks (|> (r.set n.hash num-picks (pick current-env/size)) - (:: @ map set.to-list)) - [arity bodyA predictionA] (recur (inc arity) - (list@map (function (_ pick) - (maybe.assume (list.nth pick current-env))) - picks)) - #let [picked-env (list@map (|>> #////reference.Foreign) picks)]] - (wrap [arity - (#////analysis.Function picked-env bodyA) - predictionA])) - (do @ - [chosen (pick (list.size current-env))] - (wrap [arity - (#////analysis.Reference (////reference.foreign chosen)) - (maybe.assume (dict.get chosen resolver))])))))))] - (wrap [arity - (#////analysis.Function local-env bodyA) - predictionA]))) - -(def: local-function - (Random [Arity Analysis Variable]) - (loop [arity 0 - nest? #1] - (if nest? - (do r.monad - [nest?' r.bit - [arity' bodyA predictionA] (recur (inc arity) nest?')] - (wrap [arity' - (#////analysis.Function (list) bodyA) - predictionA])) - (do {@ r.monad} - [chosen (|> r.nat (:: @ map (|>> (n.% 100) (n.max 2))))] - (wrap [arity - (#////analysis.Reference (////reference.local chosen)) - (|> chosen (n.+ (dec arity)) #////reference.Local)]))))) - -(def: abstraction - Test - (do r.monad - [[arity//constant function//constant prediction//constant] constant-function - [arity//environment function//environment prediction//environment] function-with-environment - [arity//local function//local prediction//local] local-function] - ($_ _.and - (_.test "Nested functions will get folded together." - (|> function//constant - //.phase - (///.run [///bundle.empty ////synthesis.init]) - (case> (^ (#try.Success (////synthesis.function/abstraction [environment arity output]))) - (and (n.= arity//constant arity) - (//primitive.corresponds? prediction//constant output)) - - _ - (n.= 0 arity//constant)))) - (_.test "Folded functions provide direct access to environment variables." - (|> function//environment - //.phase - (///.run [///bundle.empty ////synthesis.init]) - (case> (^ (#try.Success (////synthesis.function/abstraction [environment arity (#////synthesis.Reference (////reference.variable output))]))) - (and (n.= arity//environment arity) - (variable@= prediction//environment output)) - - _ - #0))) - (_.test "Folded functions properly offset local variables." - (|> function//local - //.phase - (///.run [///bundle.empty ////synthesis.init]) - (case> (^ (#try.Success (////synthesis.function/abstraction [environment arity (#////synthesis.Reference (////reference.variable output))]))) - (and (n.= arity//local arity) - (variable@= prediction//local output)) - - _ - #0))) - ))) - -(def: application - Test - (do {@ r.monad} - [arity (|> r.nat (:: @ map (|>> (n.% 10) (n.max 1)))) - funcA //primitive.primitive - argsA (r.list arity //primitive.primitive)] - ($_ _.and - (_.test "Can synthesize function application." - (|> (////analysis.apply [funcA argsA]) - //.phase - (///.run [///bundle.empty ////synthesis.init]) - (case> (^ (#try.Success (////synthesis.function/apply [funcS argsS]))) - (and (//primitive.corresponds? funcA funcS) - (list.every? (product.uncurry //primitive.corresponds?) - (list.zip2 argsA argsS))) - - _ - #0))) - (_.test "Function application on no arguments just synthesizes to the function itself." - (|> (////analysis.apply [funcA (list)]) - //.phase - (///.run [///bundle.empty ////synthesis.init]) - (case> (#try.Success funcS) - (//primitive.corresponds? funcA funcS) - - _ - #0))) - ))) - -(def: #export test - Test - (<| (_.context (name.module (name-of /._))) - ($_ _.and - ..abstraction - ..application - ))) diff --git a/stdlib/source/test/lux/tool/compiler/phase/synthesis/primitive.lux b/stdlib/source/test/lux/tool/compiler/phase/synthesis/primitive.lux deleted file mode 100644 index d9d24ea21..000000000 --- a/stdlib/source/test/lux/tool/compiler/phase/synthesis/primitive.lux +++ /dev/null @@ -1,80 +0,0 @@ -(.module: - [lux (#- primitive) - [abstract ["." monad (#+ do)]] - [data - ["%" text/format (#+ format)] - ["." name]] - ["r" math/random (#+ Random) ("#@." monad)] - ["_" test (#+ Test)] - [control - pipe - ["." try]]] - {1 - ["." / #_ - ["/#" // - ["/#" // - [extension - ["#." bundle]] - ["/#" // - ["#." analysis (#+ Analysis)] - ["#." synthesis (#+ Synthesis)]]]]]}) - -(def: #export primitive - (Random Analysis) - (do r.monad - [primitive (: (Random ////analysis.Primitive) - ($_ r.or - (wrap []) - r.bit - r.nat - r.int - r.rev - r.frac - (r.unicode 5)))] - (wrap (#////analysis.Primitive primitive)))) - -(def: #export (corresponds? analysis synthesis) - (-> Analysis Synthesis Bit) - (`` (case [analysis synthesis] - (~~ (template [ ] - [[(#////analysis.Primitive ( expected)) - (#////synthesis.Primitive ( actual))] - (is? (|> expected ) - (|> actual ))] - - [#////analysis.Unit (:coerce Text) #////synthesis.Text (|>)] - [#////analysis.Bit (|>) #////synthesis.Bit (|>)] - [#////analysis.Nat .i64 #////synthesis.I64 .i64] - [#////analysis.Int .i64 #////synthesis.I64 .i64] - [#////analysis.Rev .i64 #////synthesis.I64 .i64] - [#////analysis.Frac (|>) #////synthesis.F64 (|>)] - [#////analysis.Text (|>) #////synthesis.Text (|>)] - )) - - _ - false))) - -(def: #export test - Test - (<| (_.context (%.name (name-of #////synthesis.Primitive))) - (`` ($_ _.and - (~~ (template [ ] - [(do r.monad - [expected ] - (_.test (%.name (name-of )) - (|> (#////analysis.Primitive ( expected)) - //.phase - (///.run [///bundle.empty ////synthesis.init]) - (case> (#try.Success (#////synthesis.Primitive ( actual))) - (is? expected actual) - - _ - false))))] - - [#////analysis.Unit #////synthesis.Text (r@wrap ////synthesis.unit)] - [#////analysis.Bit #////synthesis.Bit r.bit] - [#////analysis.Nat #////synthesis.I64 (r@map .i64 r.nat)] - [#////analysis.Int #////synthesis.I64 (r@map .i64 r.int)] - [#////analysis.Rev #////synthesis.I64 (r@map .i64 r.rev)] - [#////analysis.Frac #////synthesis.F64 r.frac] - [#////analysis.Text #////synthesis.Text (r.unicode 5)])))))) diff --git a/stdlib/source/test/lux/tool/compiler/phase/synthesis/structure.lux b/stdlib/source/test/lux/tool/compiler/phase/synthesis/structure.lux deleted file mode 100644 index d59065782..000000000 --- a/stdlib/source/test/lux/tool/compiler/phase/synthesis/structure.lux +++ /dev/null @@ -1,77 +0,0 @@ -(.module: - [lux #* - [abstract ["." monad (#+ do)]] - [data - ["%" text/format (#+ format)] - ["." name]] - ["r" math/random (#+ Random) ("#@." monad)] - ["_" test (#+ Test)] - [control - pipe - ["." try]] - [data - ["." bit ("#@." equivalence)] - ["." product] - [number - ["n" nat]] - [collection - ["." list]]]] - ["." // #_ - ["#." primitive]] - {1 - ["." / #_ - ["/#" // - ["/#" // - [extension - ["#." bundle]] - ["/#" // - ["#." analysis (#+ Analysis)] - ["#." synthesis (#+ Synthesis)]]]]]}) - -(def: variant - Test - (do {@ r.monad} - [size (|> r.nat (:: @ map (|>> (n.% 10) (n.+ 2)))) - tagA (|> r.nat (:: @ map (n.% size))) - #let [right? (n.= (dec size) tagA) - lefts (if right? - (dec tagA) - tagA)] - memberA //primitive.primitive] - (_.test "Can synthesize variants." - (|> (////analysis.variant [lefts right? memberA]) - //.phase - (///.run [///bundle.empty ////synthesis.init]) - (case> (^ (#try.Success (////synthesis.variant [leftsS right?S valueS]))) - (let [tagS (if right?S (inc leftsS) leftsS)] - (and (n.= tagA tagS) - (|> tagS (n.= (dec size)) (bit@= right?S)) - (//primitive.corresponds? memberA valueS))) - - _ - false))))) - -(def: tuple - Test - (do {@ r.monad} - [size (|> r.nat (:: @ map (|>> (n.% 10) (n.max 2)))) - membersA (r.list size //primitive.primitive)] - (_.test "Can synthesize tuple." - (|> (////analysis.tuple membersA) - //.phase - (///.run [///bundle.empty ////synthesis.init]) - (case> (^ (#try.Success (////synthesis.tuple membersS))) - (and (n.= size (list.size membersS)) - (list.every? (product.uncurry //primitive.corresponds?) - (list.zip2 membersA membersS))) - - _ - false))))) - -(def: #export test - Test - (<| (_.context (%.name (name-of #////synthesis.Structure))) - ($_ _.and - ..variant - ..tuple - ))) -- cgit v1.2.3