diff options
Diffstat (limited to '')
21 files changed, 1162 insertions, 1111 deletions
diff --git a/stdlib/source/lux/data/name.lux b/stdlib/source/lux/data/name.lux index 59e004ea7..bd4b80c69 100644 --- a/stdlib/source/lux/data/name.lux +++ b/stdlib/source/lux/data/name.lux @@ -5,13 +5,11 @@ [codec (#+ Codec)] hash] [data - ["." text ("#;." monoid hash)]]]) + ["." text ("#@." monoid hash)]]]) -## [Types] ## (type: Name ## [Text Text]) -## [Functions] (template [<name> <side>] [(def: #export (<name> [module short]) (-> Name Text) @@ -21,21 +19,20 @@ [short short] ) -## [Structures] (structure: #export equivalence (Equivalence Name) (def: (= [xmodule xname] [ymodule yname]) - (and (text;= xmodule ymodule) - (text;= xname yname)))) + (and (text@= xmodule ymodule) + (text@= xname yname)))) (structure: #export codec (Codec Text Name) (def: (encode [module short]) (case module "" short - _ ($_ text;compose module "." short))) + _ ($_ text@compose module "." short))) (def: (decode input) - (if (text;= "" input) - (#.Left (text;compose "Invalid format for Name: " input)) + (if (text@= "" input) + (#.Left (text@compose "Invalid format for Name: " input)) (case (text.split-all-with "." input) (^ (list short)) (#.Right ["" short]) @@ -44,10 +41,10 @@ (#.Right [module short]) _ - (#.Left (text;compose "Invalid format for Name: " input)))))) + (#.Left (text@compose "Invalid format for Name: " input)))))) (structure: #export hash (Hash Name) (def: &equivalence ..equivalence) (def: (hash [module name]) - (n/+ (text;hash module) (text;hash name)))) + (n/+ (text@hash module) (text@hash name)))) diff --git a/stdlib/source/lux/tool/compiler/default/syntax.lux b/stdlib/source/lux/tool/compiler/default/syntax.lux index 06d8b6d72..b7197f3af 100644 --- a/stdlib/source/lux/tool/compiler/default/syntax.lux +++ b/stdlib/source/lux/tool/compiler/default/syntax.lux @@ -46,11 +46,6 @@ [macro ["." template]]]) -## TODO: Optimize how forms, tuples & records are parsed in the end. -## There is repeated-work going on when parsing the white-space before the -## closing parenthesis/bracket/brace. -## That repeated-work should be avoided. - ## TODO: Implement "lux syntax char case!" as a custom extension. ## That way, it should be possible to obtain the char without wrapping ## it into a java.lang.Long, thereby improving performance. @@ -58,6 +53,12 @@ ## TODO: Make an extension to take advantage of java/lang/String::indexOf<int,int> ## to get better performance than the current "lux text index" extension. +## TODO: Instead of always keeping a "where" cursor variable, keep the +## individual components (i.e. file, line and column) separate, so +## that updated the "where" only involved updating the components, and +## producing the cursors only involved building them, without any need +## for pattern-matching and de-structuring. + (type: Char Nat) (template [<name> <extension> <diff>] @@ -454,14 +455,23 @@ [(~~ (static ..open-form))] (parse-form <recur> <consume-1>) + [(~~ (static ..close-form))] + (!close ..close-form) + ## Tuple [(~~ (static ..open-tuple))] (parse-tuple <recur> <consume-1>) + [(~~ (static ..close-tuple))] + (!close ..close-tuple) + ## Record [(~~ (static ..open-record))] (parse-record <recur> <consume-1>) + [(~~ (static ..close-record))] + (!close ..close-record) + ## Text [(~~ (static ..text-delimiter))] (let [offset/1 (!inc offset/0)] @@ -515,16 +525,7 @@ [(~~ (static ..positive-sign)) (~~ (static ..negative-sign))] (!parse-signed source-code//size offset/0 where source-code - (!end-of-file where offset/0 source-code current-module)) - - [(~~ (static ..close-form))] - (!close ..close-form) - - [(~~ (static ..close-tuple))] - (!close ..close-tuple) - - [(~~ (static ..close-record))] - (!close ..close-record)] + (!end-of-file where offset/0 source-code current-module))] ## else (if (!digit? char/0) diff --git a/stdlib/source/lux/tool/compiler/phase/analysis/reference.lux b/stdlib/source/lux/tool/compiler/phase/analysis/reference.lux index 79d2c9ebd..da142fed8 100644 --- a/stdlib/source/lux/tool/compiler/phase/analysis/reference.lux +++ b/stdlib/source/lux/tool/compiler/phase/analysis/reference.lux @@ -3,10 +3,10 @@ [abstract monad] [control - ["ex" exception (#+ exception:)]] + ["." exception (#+ exception:)]] ["." macro] [data - ["." text ("#;." equivalence) + ["." text ("#@." equivalence) format]]] ["." // #_ ["#." scope] @@ -18,11 +18,13 @@ ["/" analysis (#+ Analysis Operation)]]]]) (exception: #export (foreign-module-has-not-been-imported {current Text} {foreign Text}) - (ex.report ["Current" current] - ["Foreign" foreign])) + (exception.report + ["Current" current] + ["Foreign" foreign])) -(exception: #export (definition-has-not-been-expored {definition Name}) - (ex.report ["Definition" (%name definition)])) +(exception: #export (definition-has-not-been-exported {definition Name}) + (exception.report + ["Definition" (%name definition)])) (def: (definition def-name) (-> Name (Operation Analysis)) @@ -38,7 +40,7 @@ [_ (//type.infer actualT) (^@ def-name [::module ::name]) (///extension.lift (macro.normalize def-name)) current (///extension.lift macro.current-module-name)] - (if (text;= current ::module) + (if (text@= current ::module) <return> (if (macro.export? def-anns) (do @ @@ -46,7 +48,7 @@ (if imported! <return> (///.throw foreign-module-has-not-been-imported [current ::module]))) - (///.throw definition-has-not-been-expored def-name)))))))) + (///.throw definition-has-not-been-exported def-name)))))))) (def: (variable var-name) (-> Text (Operation (Maybe Analysis))) diff --git a/stdlib/source/lux/tool/compiler/phase/extension/analysis/common.lux b/stdlib/source/lux/tool/compiler/phase/extension/analysis/common.lux index 71ecd5d8a..a62fee79f 100644 --- a/stdlib/source/lux/tool/compiler/phase/extension/analysis/common.lux +++ b/stdlib/source/lux/tool/compiler/phase/extension/analysis/common.lux @@ -25,7 +25,6 @@ [evaluation (#+ Eval)]] ["#." analysis (#+ Analysis Handler Bundle)]]]]) -## [Utils] (def: (simple inputsT+ outputT) (-> (List Type) Type Handler) (let [num-expected (list.size inputsT+)] @@ -58,7 +57,6 @@ (-> Type Type Type Type Handler) (simple (list subjectT param0T param1T) outputT)) -## [Analysers] ## "lux is" represents reference/pointer equality. (def: lux::is Handler diff --git a/stdlib/source/lux/type.lux b/stdlib/source/lux/type.lux index 031e5025d..31de534eb 100644 --- a/stdlib/source/lux/type.lux +++ b/stdlib/source/lux/type.lux @@ -4,16 +4,17 @@ [equivalence (#+ Equivalence)] [monad (#+ Monad do)]] [control - ["p" parser]] + ["p" parser] + ["." function]] [data - ["." text ("#;." monoid equivalence)] - ["." name ("#;." equivalence codec)] + ["." text ("#@." monoid equivalence)] + ["." name ("#@." equivalence codec)] [number - ["." nat ("#;." decimal)]] + ["." nat ("#@." decimal)]] ["." maybe] [collection ["." array] - ["." list ("#;." functor monoid fold)]]] + ["." list ("#@." functor monoid fold)]]] ["." macro ["." code] ["s" syntax (#+ Syntax syntax:)]]]) @@ -22,7 +23,7 @@ (-> (List Type) Type Type) (case type (#.Primitive name params) - (#.Primitive name (list;map (beta-reduce env) params)) + (#.Primitive name (list@map (beta-reduce env) params)) (^template [<tag>] (<tag> left right) @@ -37,12 +38,12 @@ (<tag> env def) _ - (<tag> (list;map (beta-reduce env) old-env) def))) + (<tag> (list@map (beta-reduce env) old-env) def))) ([#.UnivQ] [#.ExQ]) (#.Parameter idx) - (maybe.default (error! (text;compose "Unknown type var: " (nat;encode idx))) + (maybe.default (error! (text@compose "Unknown type var: " (nat@encode idx))) (list.nth idx env)) _ @@ -53,9 +54,9 @@ (def: (= x y) (case [x y] [(#.Primitive xname xparams) (#.Primitive yname yparams)] - (and (text;= xname yname) + (and (text@= xname yname) (n/= (list.size yparams) (list.size xparams)) - (list;fold (.function (_ [x y] prev) (and prev (= x y))) + (list@fold (.function (_ [x y] prev) (and prev (= x y))) #1 (list.zip2 xparams yparams))) @@ -70,7 +71,7 @@ (= xright yright)) [(#.Named xname xtype) (#.Named yname ytype)] - (and (name;= xname yname) + (and (name@= xname yname) (= xtype ytype)) (^template [<tag>] @@ -82,7 +83,7 @@ [(#.ExQ xenv xbody) (#.ExQ yenv ybody)]) (and (n/= (list.size yenv) (list.size xenv)) (= xbody ybody) - (list;fold (.function (_ [x y] prev) (and prev (= x y))) + (list@fold (.function (_ [x y] prev) (and prev (= x y))) #1 (list.zip2 xenv yenv))) @@ -121,7 +122,7 @@ (case type (#.Apply arg func') (let [[func args] (flatten-application func')] - [func (list;compose args (list arg))]) + [func (list@compose args (list arg))]) _ [type (list)])) @@ -169,7 +170,7 @@ (case type (#.Primitive name params) (` (#.Primitive (~ (code.text name)) - (.list (~+ (list;map to-code params))))) + (.list (~+ (list@map to-code params))))) (^template [<tag>] (<tag> idx) @@ -187,7 +188,7 @@ (^template [<tag>] (<tag> env body) - (` (<tag> (.list (~+ (list;map to-code env))) + (` (<tag> (.list (~+ (list@map to-code env))) (~ (to-code body))))) ([#.UnivQ] [#.ExQ]) )) @@ -196,56 +197,57 @@ (-> Type Text) (case type (#.Primitive name params) - (case params - #.Nil - ($_ text;compose "(primitive " name ")") - - _ - ($_ text;compose "(primitive " name " " (|> params (list;map to-text) list.reverse (list.interpose " ") (list;fold text;compose "")) ")")) + ($_ text@compose + "(primitive " + (text.enclose' text.double-quote name) + (|> params + (list@map (|>> to-text (text@compose " "))) + (list@fold (function.flip text@compose) "")) + ")") (^template [<tag> <open> <close> <flatten>] (<tag> _) - ($_ text;compose <open> + ($_ text@compose <open> (|> (<flatten> type) - (list;map to-text) + (list@map to-text) list.reverse (list.interpose " ") - (list;fold text;compose "")) + (list@fold text@compose "")) <close>)) ([#.Sum "(| " ")" flatten-variant] [#.Product "[" "]" flatten-tuple]) (#.Function input output) (let [[ins out] (flatten-function type)] - ($_ text;compose "(-> " + ($_ text@compose "(-> " (|> ins - (list;map to-text) + (list@map to-text) list.reverse (list.interpose " ") - (list;fold text;compose "")) + (list@fold text@compose "")) " " (to-text out) ")")) (#.Parameter idx) - (nat;encode idx) + (nat@encode idx) (#.Var id) - ($_ text;compose "⌈v:" (nat;encode id) "⌋") + ($_ text@compose "⌈v:" (nat@encode id) "⌋") (#.Ex id) - ($_ text;compose "⟨e:" (nat;encode id) "⟩") + ($_ text@compose "⟨e:" (nat@encode id) "⟩") (#.Apply param fun) (let [[type-func type-args] (flatten-application type)] - ($_ text;compose "(" (to-text type-func) " " (|> type-args (list;map to-text) list.reverse (list.interpose " ") (list;fold text;compose "")) ")")) + ($_ text@compose "(" (to-text type-func) " " (|> type-args (list@map to-text) list.reverse (list.interpose " ") (list@fold text@compose "")) ")")) (^template [<tag> <desc>] (<tag> env body) - ($_ text;compose "(" <desc> " {" (|> env (list;map to-text) (text.join-with " ")) "} " (to-text body) ")")) + ($_ text@compose "(" <desc> " {" (|> env (list@map to-text) (text.join-with " ")) "} " (to-text body) ")")) ([#.UnivQ "All"] [#.ExQ "Ex"]) (#.Named [module name] type) - ($_ text;compose module "." name) + ($_ text@compose module "." name) )) (def: #export (un-alias type) @@ -343,9 +345,9 @@ (do @ [cursor macro.cursor valueT (macro.find-type valueN) - #let [_ (log! ($_ text;compose + #let [_ (log! ($_ text@compose ":log!" " @ " (.cursor-description cursor) text.new-line - (name;encode valueN) " : " (..to-text valueT) text.new-line))]] + (name@encode valueN) " : " (..to-text valueT) text.new-line))]] (wrap (list (code.identifier valueN)))) (#.Right valueC) @@ -361,7 +363,7 @@ input output {value (p.maybe s.any)}) - (let [casterC (` (: (All [(~+ (list;map code.local-identifier type-vars))] + (let [casterC (` (: (All [(~+ (list@map code.local-identifier type-vars))] (-> (~ input) (~ output))) (|>> :assume)))] (case value @@ -384,7 +386,7 @@ {exemplar typed} {computation typed}) (macro.with-gensyms [g!_] - (let [shareC (` (: (All [(~+ (list;map code.local-identifier type-vars))] + (let [shareC (` (: (All [(~+ (list@map code.local-identifier type-vars))] (-> (~ (get@ #type exemplar)) (~ (get@ #type computation)))) (.function ((~ g!_) (~ g!_)) @@ -395,7 +397,7 @@ (syntax: #export (:by-example {type-vars type-parameters} {exemplar typed} {extraction s.any}) - (wrap (list (` (:of (:share [(~+ (list;map code.local-identifier type-vars))] + (wrap (list (` (:of (:share [(~+ (list@map code.local-identifier type-vars))] {(~ (get@ #type exemplar)) (~ (get@ #expression exemplar))} {(~ extraction) diff --git a/stdlib/source/test/lux.lux b/stdlib/source/test/lux.lux index 77f0e1bbd..bad2e5500 100644 --- a/stdlib/source/test/lux.lux +++ b/stdlib/source/test/lux.lux @@ -18,6 +18,7 @@ ["." io (#+ io)] ["." function]] [data + ["." name] [number ["." i64]]] ["." math] @@ -296,7 +297,7 @@ on-default)))))) (def: test - (<| (_.context (%name (name-of /._))) + (<| (_.context (name.module (name-of /._))) ($_ _.and (<| (_.context "Identity.") ..identity) @@ -348,8 +349,7 @@ /math.test (<| (_.context "/time") /time.test) - (<| (_.context "/tool") - /tool.test) + /tool.test /type.test /world.test (<| (_.context "/host") diff --git a/stdlib/source/test/lux/compiler/default/phase/analysis/case.lux b/stdlib/source/test/lux/compiler/default/phase/analysis/case.lux deleted file mode 100644 index 5c47960c1..000000000 --- a/stdlib/source/test/lux/compiler/default/phase/analysis/case.lux +++ /dev/null @@ -1,198 +0,0 @@ -(.module: - [lux #* - [control - ["." monad (#+ do)] - pipe] - [data - ["." product] - ["." maybe] - ["." text ("#;." equivalence)] - [collection - ["." list ("#;." monad)] - ["." set]]] - [math - ["r" random ("#;." monad)]] - ["." type - ["." check]] - [macro - ["." code]] - [compiler - [default - ["." phase - ["." analysis - ["." module] - [".A" type] - ["/" case]]]]] - test] - [// - ["_." primitive] - ["_." structure]]) - -(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 (r.Random (List Code))) - (case inputC - [_ (#.Bit _)] - (r;wrap (list (' #1) (' #0))) - - (^template [<tag> <gen> <wrapper>] - [_ (<tag> _)] - (if allow-literals? - (do r.monad - [?sample (r.maybe <gen>)] - (case ?sample - (#.Some sample) - (do @ - [else (exhaustive-branches allow-literals? variantTC inputC)] - (wrap (list& (<wrapper> 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 (' []))) - - (^ [_ (#.Record (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 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) (r.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]) - -(context: "Pattern-matching." - ## #seed 9253409297339902486 - ## #seed 3793366152923578600 - (<| (seed 5004137551292836565) - ## (times 100) - (do @ - [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] _primitive.primitive - [heterogeneousT heterogeneousC] (r.filter (|>> product.left (check.checks? outputT) not) - _primitive.primitive) - exhaustive-patterns (exhaustive-branches #1 variantTC inputC) - redundant-patterns (exhaustive-branches #0 variantTC inputC) - redundancy-idx (|> r.nat (:: @ map (n/% (list.size redundant-patterns)))) - heterogeneous-idx (|> r.nat (:: @ map (n/% (list.size exhaustive-patterns)))) - #let [exhaustive-branchesC (list;map (branch outputC) - exhaustive-patterns) - non-exhaustive-branchesC (list.take (dec (list.size exhaustive-branchesC)) - exhaustive-branchesC) - 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))) - 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))) - analyse-pm (|>> (/.case _primitive.phase inputC) - (typeA.with-type outputT) - analysis.with-scope - (do phase.monad - [_ (module.declare-tags variant-tags #0 - (#.Named [module-name variant-name] - (type.variant primitivesT))) - _ (module.declare-tags record-tags #0 - (#.Named [module-name record-name] - (type.tuple primitivesT)))]) - (module.with-module 0 module-name))]] - ($_ seq - (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)) - (test "Will reject non-exhaustive pattern-matching." - (|> (analyse-pm non-exhaustive-branchesC) - _structure.check-fails)) - (test "Will reject redundant pattern-matching." - (|> (analyse-pm redundant-branchesC) - _structure.check-fails)) - (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/compiler/default/phase/analysis/function.lux b/stdlib/source/test/lux/compiler/default/phase/analysis/function.lux deleted file mode 100644 index acdb9e7ff..000000000 --- a/stdlib/source/test/lux/compiler/default/phase/analysis/function.lux +++ /dev/null @@ -1,118 +0,0 @@ -(.module: - [lux #* - [control - [monad (#+ do)] - pipe] - [data - ["." error] - ["." maybe] - ["." product] - ["." text ("#;." equivalence) - format] - [collection - ["." list ("#;." functor)]]] - [math - ["r" random]] - ["." type] - ["." macro - ["." code]] - [compiler - [default - ["." reference] - ["." init] - ["." phase - ["." analysis (#+ Analysis Operation) - [".A" type] - ["." expression] - ["/" function]] - [extension - [".E" analysis]]]]] - test] - [// - ["_." primitive] - ["_." structure]]) - -(def: (check-apply expectedT num-args analysis) - (-> Type Nat (Operation Analysis) Bit) - (|> analysis - (typeA.with-type expectedT) - (phase.run _primitive.state) - (case> (#error.Success applyA) - (let [[funcA argsA] (analysis.application applyA)] - (n/= num-args (list.size argsA))) - - (#error.Failure error) - #0))) - -(context: "Function definition." - (<| (times 100) - (do @ - [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)]] - ($_ seq - (test "Can analyse function." - (and (|> (typeA.with-type (All [a] (-> a outputT)) - (/.function _primitive.phase func-name arg-name outputC)) - _structure.check-succeeds) - (|> (typeA.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 (|> (typeA.with-type (-> inputT outputT) - (/.function _primitive.phase func-name arg-name outputC)) - _structure.check-succeeds) - (|> (typeA.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." - (|> (typeA.with-type (Rec self (-> inputT self)) - (/.function _primitive.phase func-name arg-name (code.local-identifier func-name))) - _structure.check-succeeds)) - )))) - -(context: "Function application." - (<| (times 100) - (do @ - [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)))]] - ($_ seq - (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))) - )))) diff --git a/stdlib/source/test/lux/compiler/default/phase/analysis/primitive.lux b/stdlib/source/test/lux/compiler/default/phase/analysis/primitive.lux deleted file mode 100644 index e60a7c40c..000000000 --- a/stdlib/source/test/lux/compiler/default/phase/analysis/primitive.lux +++ /dev/null @@ -1,100 +0,0 @@ -(.module: - [lux (#- primitive) - [control - [monad (#+ do)] - pipe - ["ex" exception (#+ exception:)]] - [data - ["." error (#+ Error)] - [text - format]] - [math - ["r" random ("#;." monad)]] - ["." type ("#;." equivalence)] - [macro - ["." code]] - [compiler - [default - ["." init] - [evaluation (#+ Eval)] - ["." phase - ["." analysis (#+ Analysis Operation) - [".A" type] - ["." expression]] - [extension - [".E" analysis]]]]] - test]) - -(def: #export phase - analysis.Phase - expression.compile) - -(def: #export state - analysis.State+ - [(analysisE.bundle (:coerce Eval [])) (init.compiler [])]) - -(def: unit - (r.Random Code) - (r;wrap (' []))) - -(def: #export primitive - (r.Random [Type Code]) - (`` ($_ r.either - (~~ (template [<type> <code-wrapper> <value-gen>] - [(r.and (r;wrap <type>) (r;map <code-wrapper> <value-gen>))] - - [Any code.tuple (r.list 0 ..unit)] - [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}) - (ex.report ["Expected" (%type expected)] - ["Inferred" (%type inferred)])) - -(def: (infer-primitive expected-type analysis) - (-> Type (Operation Analysis) (Error Analysis)) - (|> analysis - typeA.with-inference - (phase.run ..state) - (case> (#error.Success [inferred-type output]) - (if (is? expected-type inferred-type) - (#error.Success output) - (ex.throw wrong-inference [expected-type inferred-type])) - - (#error.Failure error) - (#error.Failure error)))) - -(context: "Primitives" - ($_ seq - (test "Can analyse unit." - (|> (infer-primitive Any (..phase (' []))) - (case> (^ (#error.Success (#analysis.Primitive (#analysis.Unit output)))) - (is? [] output) - - _ - #0))) - (<| (times 100) - (`` ($_ seq - (~~ (template [<desc> <type> <tag> <random> <constructor>] - [(do @ - [sample <random>] - (test (format "Can analyse " <desc> ".") - (|> (infer-primitive <type> (..phase (<constructor> sample))) - (case> (#error.Success (#analysis.Primitive (<tag> output))) - (is? sample output) - - _ - #0))))] - - ["bit" Bit #analysis.Bit r.bit code.bit] - ["nat" Nat #analysis.Nat r.nat code.nat] - ["int" Int #analysis.Int r.int code.int] - ["rev" Rev #analysis.Rev r.rev code.rev] - ["frac" Frac #analysis.Frac r.frac code.frac] - ["text" Text #analysis.Text (r.unicode 5) code.text] - ))))))) diff --git a/stdlib/source/test/lux/compiler/default/phase/analysis/procedure/common.lux b/stdlib/source/test/lux/compiler/default/phase/analysis/procedure/common.lux deleted file mode 100644 index bf7de5cec..000000000 --- a/stdlib/source/test/lux/compiler/default/phase/analysis/procedure/common.lux +++ /dev/null @@ -1,187 +0,0 @@ -(.module: - [lux #* - [io] - [control - [monad (#+ do)] - pipe] - [concurrency - ["." atom]] - [data - ["." error] - ["." product] - [text - format]] - [math - ["r" random]] - ["." type ("#;." equivalence)] - [macro - ["." code]] - [compiler - [default - ["." init] - ["." phase - [analysis - ["." scope] - [".A" type]] - [extension - [".E" analysis]]]]] - test] - [/// - ["_." primitive]]) - -(template [<name> <success> <failure>] - [(def: (<name> procedure params output-type) - (-> Text (List Code) Type Bit) - (|> (scope.with-scope "" - (typeA.with-type output-type - (_primitive.phase (` ((~ (code.text procedure)) (~+ params)))))) - (phase.run _primitive.state) - (case> (#error.Success _) - <success> - - (#error.Failure error) - <failure>)))] - - [check-success+ #1 #0] - [check-failure+ #0 #1] - ) - -(context: "Lux procedures" - (<| (times 100) - (do @ - [[primT primC] _primitive.primitive - [antiT antiC] (|> _primitive.primitive - (r.filter (|>> product.left (type;= primT) not)))] - ($_ seq - (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 (` ([(~' _) (~' _)] (~ primC)))) - (type (Either Text primT)))) - )))) - -(context: "Bit procedures" - (<| (times 100) - (do @ - [subjectC (|> r.nat (:: @ map code.nat)) - signedC (|> r.int (:: @ map code.int)) - paramC (|> r.nat (:: @ map code.nat))] - ($_ seq - (test "Can perform bit 'and'." - (check-success+ "lux bit and" (list subjectC paramC) Nat)) - (test "Can perform bit 'or'." - (check-success+ "lux bit or" (list subjectC paramC) Nat)) - (test "Can perform bit 'xor'." - (check-success+ "lux bit xor" (list subjectC paramC) Nat)) - (test "Can shift bit pattern to the left." - (check-success+ "lux bit left-shift" (list subjectC paramC) Nat)) - (test "Can shift bit pattern to the right." - (check-success+ "lux bit logical-right-shift" (list subjectC paramC) Nat)) - (test "Can shift signed bit pattern to the right." - (check-success+ "lux bit arithmetic-right-shift" (list signedC paramC) Int)) - )))) - -(context: "Int procedures" - (<| (times 100) - (do @ - [subjectC (|> r.int (:: @ map code.int)) - paramC (|> r.int (:: @ map code.int))] - ($_ seq - (test "Can add integers." - (check-success+ "lux int +" (list paramC subjectC) Int)) - (test "Can subtract integers." - (check-success+ "lux int -" (list paramC subjectC) Int)) - (test "Can multiply integers." - (check-success+ "lux int *" (list paramC subjectC) Int)) - (test "Can divide integers." - (check-success+ "lux int /" (list paramC subjectC) Int)) - (test "Can calculate remainder of integers." - (check-success+ "lux int %" (list paramC subjectC) Int)) - (test "Can test equivalence of integers." - (check-success+ "lux int =" (list paramC subjectC) Bit)) - (test "Can compare integers." - (check-success+ "lux int <" (list paramC subjectC) Bit)) - (test "Can convert integer to fraction." - (check-success+ "lux int to-frac" (list subjectC) Frac)) - (test "Can convert integer to text." - (check-success+ "lux int char" (list subjectC) Text)) - )))) - -(context: "Frac procedures" - (<| (times 100) - (do @ - [subjectC (|> r.frac (:: @ map code.frac)) - paramC (|> r.frac (:: @ map code.frac)) - encodedC (|> (r.unicode 5) (:: @ map code.text))] - ($_ seq - (test "Can add frac numbers." - (check-success+ "lux frac +" (list paramC subjectC) Frac)) - (test "Can subtract frac numbers." - (check-success+ "lux frac -" (list paramC subjectC) Frac)) - (test "Can multiply frac numbers." - (check-success+ "lux frac *" (list paramC subjectC) Frac)) - (test "Can divide frac numbers." - (check-success+ "lux frac /" (list paramC subjectC) Frac)) - (test "Can calculate remainder of frac numbers." - (check-success+ "lux frac %" (list paramC subjectC) Frac)) - (test "Can test equivalence of frac numbers." - (check-success+ "lux frac =" (list paramC subjectC) Bit)) - (test "Can compare frac numbers." - (check-success+ "lux frac <" (list paramC subjectC) Bit)) - (test "Can obtain minimum frac number." - (check-success+ "lux frac min" (list) Frac)) - (test "Can obtain maximum frac number." - (check-success+ "lux frac max" (list) Frac)) - (test "Can obtain smallest frac number." - (check-success+ "lux frac smallest" (list) Frac)) - (test "Can convert frac number to integer." - (check-success+ "lux frac to-int" (list subjectC) Int)) - (test "Can convert frac number to text." - (check-success+ "lux frac encode" (list subjectC) Text)) - (test "Can convert text to frac number." - (check-success+ "lux frac decode" (list encodedC) (type (Maybe Frac)))) - )))) - -(context: "Text procedures" - (<| (times 100) - (do @ - [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))] - ($_ seq - (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)) - )))) - -(context: "IO procedures" - (<| (times 100) - (do @ - [logC (|> (r.unicode 5) (:: @ map code.text)) - exitC (|> r.int (:: @ map code.int))] - ($_ seq - (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)) - )))) diff --git a/stdlib/source/test/lux/compiler/default/phase/analysis/reference.lux b/stdlib/source/test/lux/compiler/default/phase/analysis/reference.lux deleted file mode 100644 index a73e6c3cb..000000000 --- a/stdlib/source/test/lux/compiler/default/phase/analysis/reference.lux +++ /dev/null @@ -1,107 +0,0 @@ -(.module: - [lux #* - [control - [monad (#+ do)] - pipe] - [data - ["." error (#+ Error)] - ["." name ("#;." equivalence)] - ["." text ("#;." equivalence)]] - [math - ["r" random]] - ["." type ("#;." equivalence)] - [macro - ["." code]] - [compiler - [default - ["." reference] - ["." init] - ["." phase - ["." analysis - ["." scope] - ["." module] - [".A" type] - ["." expression]] - [extension - [".E" analysis]]]]] - test] - [// - ["_." primitive]]) - -(type: Check (-> (Error Any) Bit)) - -(template [<name> <on-success> <on-failure>] - [(def: <name> - Check - (|>> (case> (#error.Success _) - <on-success> - - (#error.Failure _) - <on-failure>)))] - - [success? #1 #0] - [failure? #0 #1] - ) - -(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 [Any - (if export? - (' {#.export? #1}) - (' {})) - []]))] - (module.with-module 0 dependent-module - (do @ - [_ (if import? - (module.import def-module) - (wrap []))] - (typeA.with-inference - (_primitive.phase (code.identifier [def-module var-name])))))) - (phase.run _primitive.state) - check!)) - -(context: "References" - (<| (times 100) - (do @ - [[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)))] - ($_ seq - (test "Can analyse variable." - (|> (scope.with-scope scope-name - (scope.with-local [var-name expectedT] - (typeA.with-inference - (_primitive.phase (code.local-identifier var-name))))) - (phase.run _primitive.state) - (case> (^ (#error.Success [inferredT (#analysis.Reference (reference.local var))])) - (and (type;= expectedT inferredT) - (n/= 0 var)) - - _ - #0))) - (test "Can analyse definition (in the same module)." - (let [def-name [def-module var-name]] - (|> (do phase.monad - [_ (module.define var-name [expectedT (' {}) []])] - (typeA.with-inference - (_primitive.phase (code.identifier def-name)))) - (module.with-module 0 def-module) - (phase.run _primitive.state) - (case> (^ (#error.Success [_ inferredT (#analysis.Reference (reference.constant constant-name))])) - (and (type;= expectedT inferredT) - (name;= def-name constant-name)) - - _ - #0)))) - (test "Can analyse definition (if exported from imported module)." - (reach-test var-name [#1 def-module] [#1 dependent-module] success?)) - (test "Cannot analyse definition (if not exported from imported module)." - (reach-test var-name [#0 def-module] [#1 dependent-module] failure?)) - (test "Cannot analyse definition (if exported from non-imported module)." - (reach-test var-name [#1 def-module] [#0 dependent-module] failure?)) - )))) diff --git a/stdlib/source/test/lux/compiler/default/phase/analysis/structure.lux b/stdlib/source/test/lux/compiler/default/phase/analysis/structure.lux deleted file mode 100644 index 186c961e9..000000000 --- a/stdlib/source/test/lux/compiler/default/phase/analysis/structure.lux +++ /dev/null @@ -1,297 +0,0 @@ -(.module: - [lux #* - [control - [monad (#+ do)] - pipe] - [data - ["." bit ("#;." equivalence)] - ["e" error] - ["." product] - ["." maybe] - ["." text] - [collection - ["." list ("#;." functor)] - ["." set]]] - [math - ["r" random]] - ["." type ("#;." equivalence) - ["." check]] - [macro - ["." code]] - [compiler - [default - ["." init] - ["." phase - ["." analysis (#+ Analysis Variant Tag Operation) - ["." module] - [".A" type] - ["/" structure] - ["." expression]] - [extension - [".E" analysis]]]]] - test] - [// - ["_." primitive]]) - -(template [<name> <on-success> <on-error>] - [(def: #export <name> - (All [a] (-> (Operation a) Bit)) - (|>> (phase.run _primitive.state) - (case> (#e.Success _) - <on-success> - - _ - <on-error>)))] - - [check-succeeds #1 #0] - [check-fails #0 #1] - ) - -(def: (check-sum' size tag variant) - (-> Nat Tag (Variant Analysis) Bit) - (let [variant-tag (if (get@ #analysis.right? variant) - (inc (get@ #analysis.lefts variant)) - (get@ #analysis.lefts variant))] - (|> size dec (n/= tag) - (bit;= (get@ #analysis.right? variant)) - (and (n/= tag variant-tag))))) - -(def: (check-sum type size tag analysis) - (-> Type Nat Tag (Operation Analysis) Bit) - (|> analysis - (typeA.with-type type) - (phase.run _primitive.state) - (case> (^ (#e.Success (analysis.variant variant))) - (check-sum' size tag variant) - - _ - #0))) - -(def: (tagged module tags type) - (All [a] (-> Text (List module.Tag) Type (Operation a) (Operation [Module a]))) - (|>> (do phase.monad - [_ (module.declare-tags tags #0 type)]) - (module.with-module 0 module))) - -(def: (check-variant module tags type size tag analysis) - (-> Text (List module.Tag) Type Nat Tag (Operation Analysis) Bit) - (|> analysis - (tagged module tags type) - (typeA.with-type type) - (phase.run _primitive.state) - (case> (^ (#e.Success [_ (analysis.variant variant)])) - (check-sum' size tag variant) - - _ - #0))) - -(def: (right-size? size) - (-> Nat (-> Analysis Bit)) - (|>> (case> (^ (analysis.tuple elems)) - (|> elems - list.size - (n/= size)) - - _ - false))) - -(def: (check-record-inference module tags type size analysis) - (-> Text (List module.Tag) Type Nat (Operation [Type Analysis]) Bit) - (|> analysis - (tagged module tags type) - (phase.run _primitive.state) - (case> (#e.Success [_ productT productA]) - (and (type;= type productT) - (right-size? size productA)) - - _ - #0))) - -(context: "Sums" - (<| (times 100) - (do @ - [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))]] - ($_ seq - (test "Can analyse sum." - (check-sum variantT size choice - (/.sum _primitive.phase choice valueC))) - (test "Can analyse sum through bound type-vars." - (|> (do phase.monad - [[_ varT] (typeA.with-env check.var) - _ (typeA.with-env - (check.check varT variantT))] - (typeA.with-type varT - (/.sum _primitive.phase choice valueC))) - (phase.run _primitive.state) - (case> (^ (#e.Success (analysis.variant variant))) - (check-sum' size choice variant) - - _ - #0))) - (test "Cannot analyse sum through unbound type-vars." - (|> (do phase.monad - [[_ varT] (typeA.with-env check.var)] - (typeA.with-type varT - (/.sum _primitive.phase choice valueC))) - check-fails)) - (test "Can analyse sum through existential quantification." - (|> (typeA.with-type (type.ex-q 1 +variantT) - (/.sum _primitive.phase +choice +valueC)) - check-succeeds)) - (test "Can analyse sum through universal quantification." - (let [check-outcome (if (not (n/= choice +choice)) - check-succeeds - check-fails)] - (|> (typeA.with-type (type.univ-q 1 +variantT) - (/.sum _primitive.phase +choice +valueC)) - check-outcome))) - )))) - -(context: "Products" - (<| (times 100) - (do @ - [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))]] - ($_ seq - (test "Can analyse product." - (|> (typeA.with-type tupleT - (/.product _primitive.phase (list;map product.right primitives))) - (phase.run _primitive.state) - (case> (#e.Success tupleA) - (right-size? size tupleA) - - _ - #0))) - (test "Can infer product." - (|> (typeA.with-inference - (/.product _primitive.phase (list;map product.right primitives))) - (phase.run _primitive.state) - (case> (#e.Success [_type tupleA]) - (and (type;= tupleT _type) - (right-size? size tupleA)) - - _ - #0))) - (test "Can analyse pseudo-product (singleton tuple)" - (|> (typeA.with-type singletonT - (_primitive.phase (` [(~ singletonC)]))) - check-succeeds)) - (test "Can analyse product through bound type-vars." - (|> (do phase.monad - [[_ varT] (typeA.with-env check.var) - _ (typeA.with-env - (check.check varT (type.tuple (list;map product.left primitives))))] - (typeA.with-type varT - (/.product _primitive.phase (list;map product.right primitives)))) - (phase.run _primitive.state) - (case> (#e.Success tupleA) - (right-size? size tupleA) - - _ - #0))) - (test "Can analyse product through existential quantification." - (|> (typeA.with-type (type.ex-q 1 +tupleT) - (/.product _primitive.phase (list;map product.right +primitives))) - check-succeeds)) - (test "Cannot analyse product through universal quantification." - (|> (typeA.with-type (type.univ-q 1 +tupleT) - (/.product _primitive.phase (list;map product.right +primitives))) - check-fails)) - )))) - -(context: "Tagged Sums" - (<| (times 100) - (do @ - [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 [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)) - variantT (type.variant primitivesT) - namedT (#.Named [module-name type-name] variantT) - named-polyT (|> (type.variant (list.concat (list (list.take choice primitivesT) - (list varT) - (list.drop (inc choice) primitivesT)))) - (type.univ-q 1) - (#.Named [module-name type-name])) - choice-tag (maybe.assume (list.nth choice tags)) - other-choice-tag (maybe.assume (list.nth other-choice tags))]] - ($_ seq - (test "Can infer tagged sum." - (|> (/.tagged-sum _primitive.phase [module-name choice-tag] choiceC) - (check-variant module-name tags namedT choice size))) - (test "Tagged sums specialize when type-vars get bound." - (|> (/.tagged-sum _primitive.phase [module-name choice-tag] choiceC) - (check-variant module-name tags named-polyT choice size))) - (test "Tagged sum 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 named-polyT other-choice size))) - (test "Can specialize generic tagged sums." - (|> (typeA.with-type variantT - (/.tagged-sum _primitive.phase [module-name other-choice-tag] other-choiceC)) - (check-variant module-name tags named-polyT other-choice size))) - )))) - -(context: "Records" - (<| (times 100) - (do @ - [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) - tupleT (type.tuple primitivesT) - namedT (#.Named [module-name type-name] tupleT) - recordC (list.zip2 tagsC primitivesC) - named-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]))]] - ($_ seq - (test "Can infer record." - (|> (typeA.with-inference - (/.record _primitive.phase recordC)) - (check-record-inference module-name tags namedT size))) - (test "Records specialize when type-vars get bound." - (|> (typeA.with-inference - (/.record _primitive.phase recordC)) - (check-record-inference module-name tags named-polyT size))) - (test "Can specialize generic records." - (|> (do phase.monad - [recordA (typeA.with-type tupleT - (/.record _primitive.phase recordC))] - (wrap [tupleT recordA])) - (check-record-inference module-name tags named-polyT size))) - )))) diff --git a/stdlib/source/test/lux/tool.lux b/stdlib/source/test/lux/tool.lux index 340e24642..91c8d385b 100644 --- a/stdlib/source/test/lux/tool.lux +++ b/stdlib/source/test/lux/tool.lux @@ -3,14 +3,6 @@ ["_" test (#+ Test)]] ## [compiler ## [phase - ## [analysis - ## ["_.A" primitive] - ## ["_.A" structure] - ## ["_.A" reference] - ## ["_.A" case] - ## ["_.A" function] - ## [procedure - ## ["_.A" common]]] ## [synthesis ## ["_.S" primitive] ## ["_.S" structure] @@ -19,10 +11,13 @@ ["." / #_ [compiler [default - ["#." syntax]]]]) + ["#." syntax]] + [phase + ["#." analysis]]]]) (def: #export test Test ($_ _.and /syntax.test + /analysis.test )) diff --git a/stdlib/source/test/lux/tool/compiler/default/syntax.lux b/stdlib/source/test/lux/tool/compiler/default/syntax.lux index 632e97023..9f36c551f 100644 --- a/stdlib/source/test/lux/tool/compiler/default/syntax.lux +++ b/stdlib/source/test/lux/tool/compiler/default/syntax.lux @@ -1,7 +1,9 @@ (.module: [lux #* - data/text/format [abstract/monad (#+ do)] + [data + text/format + ["." name]] ["r" math/random (#+ Random) ("#@." monad)] ["_" test (#+ Test)] [data @@ -25,17 +27,8 @@ (def: name-part^ (Random Text) (do r.monad - [#let [digits "0123456789" - delimiters (format "()[]{}#." /.text-delimiter) - space (format " " text.new-line) - invalid-range (format digits delimiters space) - char-gen (|> r.nat - (:: @ map (|>> (n/% 256) (n/max 1))) - (r.filter (function (_ sample) - (not (text.contains? (text.from-code sample) - invalid-range)))))] - size (|> r.nat (:: @ map (|>> (n/% 20) (n/max 1))))] - (r.text char-gen size))) + [size (|> r.nat (:: @ map (|>> (n/% 20) (n/max 1))))] + (r.ascii/lower-alpha size))) (def: name^ (Random Name) @@ -49,12 +42,12 @@ (|> r.nat (r@map code.nat)) (|> r.int (r@map code.int)) (|> r.rev (r@map code.rev)) - (|> r.frac (r@map code.frac)))) + (|> r.safe-frac (r@map code.frac)))) textual^ (: (Random Code) ($_ r.either (do r.monad [size (|> r.nat (r@map (n/% 20)))] - (|> (r.unicode size) (r@map code.text))) + (|> (r.ascii/upper-alpha size) (r@map code.text))) (|> name^ (r@map code.identifier)) (|> name^ (r@map code.tag)))) simple^ (: (Random Code) @@ -146,7 +139,8 @@ (def: #export test Test - ($_ _.and - ..code - ..comments - )) + (<| (_.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 new file mode 100644 index 000000000..d24feb8be --- /dev/null +++ b/stdlib/source/test/lux/tool/compiler/phase/analysis.lux @@ -0,0 +1,24 @@ +(.module: + [lux #* + ["_" test (#+ Test)]] + ["." / #_ + ["#." primitive] + ["#." structure] + ["#." reference] + ["#." case] + ["#." function] + ["/#" // #_ + [extension + [analysis + ["#." common]]]]]) + +(def: #export test + Test + ($_ _.and + /primitive.test + /structure.test + /reference.test + /case.test + /function.test + //common.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 new file mode 100644 index 000000000..6f5a324cd --- /dev/null +++ b/stdlib/source/test/lux/tool/compiler/phase/analysis/case.lux @@ -0,0 +1,201 @@ +(.module: + [lux #* + [abstract ["." monad (#+ do)]] + [data + text/format + ["." name ("#@." equivalence)]] + ["r" math/random (#+ Random) ("#@." monad)] + ["_" test (#+ Test)] + [control + pipe] + [data + ["." product] + ["." maybe] + ["." text ("#@." equivalence)] + [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 [<tag> <gen> <wrapper>] + [_ (<tag> _)] + (if allow-literals? + (do r.monad + [?sample (r.maybe <gen>)] + (case ?sample + (#.Some sample) + (do @ + [else (exhaustive-branches allow-literals? variantTC inputC)] + (wrap (list& (<wrapper> 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 new file mode 100644 index 000000000..8d345dae2 --- /dev/null +++ b/stdlib/source/test/lux/tool/compiler/phase/analysis/function.lux @@ -0,0 +1,125 @@ +(.module: + [lux #* + [abstract ["." monad (#+ do)]] + [data + text/format + ["." name ("#@." equivalence)]] + ["r" math/random (#+ Random) ("#@." monad)] + ["_" test (#+ Test)] + [control + pipe] + [data + ["." error] + ["." maybe] + ["." product] + ["." text ("#@." equivalence)] + [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> (#error.Success applyA) + (let [[funcA argsA] (////analysis.application applyA)] + (n/= num-args (list.size argsA))) + + (#error.Failure error) + 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 new file mode 100644 index 000000000..2ed135058 --- /dev/null +++ b/stdlib/source/test/lux/tool/compiler/phase/analysis/primitive.lux @@ -0,0 +1,108 @@ +(.module: + [lux (#- primitive) + [abstract ["." monad (#+ do)]] + [data + text/format + ["." name]] + ["r" math/random (#+ Random) ("#@." monad)] + ["_" test (#+ Test)] + [control + pipe + ["." exception (#+ exception:)]] + [data + ["." error (#+ Error)]] + ["." type ("#@." equivalence)] + [macro + ["." code]]] + {1 + ["." / + ["/#" // + ["#." type] + ["/#" // + [macro (#+ Expander)] + [extension + ["#." analysis]] + ["/#" // + ["#." analysis (#+ Analysis Operation)] + [default + [evaluation (#+ Eval)] + ["." init]]]]]]}) + +(def: #export (expander macro inputs state) + Expander + (#error.Failure "NOPE")) + +(def: #export (eval count type expression) + Eval + (function (_ state) + (#error.Failure "NO!"))) + +(def: #export phase + ////analysis.Phase + (//.phase ..expander)) + +(def: #export state + ////analysis.State+ + [(///analysis.bundle ..eval) (////analysis.state init.info [])]) + +(def: #export primitive + (Random [Type Code]) + (`` ($_ r.either + (~~ (template [<type> <code-wrapper> <value-gen>] + [(r.and (r@wrap <type>) (r@map <code-wrapper> <value-gen>))] + + [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) (Error Analysis)) + (|> analysis + //type.with-inference + (///.run ..state) + (case> (#error.Success [inferred-type output]) + (if (is? expected-type inferred-type) + (#error.Success output) + (exception.throw wrong-inference [expected-type inferred-type])) + + (#error.Failure error) + (#error.Failure error)))) + +(def: #export test + (<| (_.context (name.module (name-of /._))) + (`` ($_ _.and + (_.test (%name (name-of #////analysis.Unit)) + (|> (infer Any (..phase (' []))) + (case> (^ (#error.Success (#////analysis.Primitive (#////analysis.Unit output)))) + (is? [] output) + + _ + false))) + (~~ (template [<type> <tag> <random> <constructor>] + [(do r.monad + [sample <random>] + (_.test (%name (name-of <tag>)) + (|> (infer <type> (..phase (<constructor> sample))) + (case> (#error.Success (#////analysis.Primitive (<tag> 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 new file mode 100644 index 000000000..7356b9fad --- /dev/null +++ b/stdlib/source/test/lux/tool/compiler/phase/analysis/reference.lux @@ -0,0 +1,106 @@ +(.module: + [lux #* + [abstract ["." monad (#+ do)]] + [data + text/format + ["." name ("#@." equivalence)]] + ["r" math/random (#+ Random) ("#@." monad)] + ["_" test (#+ Test)] + [control + pipe] + [data + ["." error (#+ Error)] + ["." text ("#@." equivalence)]] + ["." type ("#@." equivalence)] + [macro + ["." code]]] + [// + ["_." primitive]] + {1 + ["." / + ["/#" // + ["#." scope] + ["#." module] + ["#." type] + ["/#" // + ["/#" // + ["#." reference] + ["#." analysis (#+ Analysis Variant Tag Operation)]]]]]}) + +(type: Check (-> (Error Any) Bit)) + +(template [<name> <on-success> <on-failure>] + [(def: <name> + Check + (|>> (case> (#error.Success _) + <on-success> + + (#error.Failure error) + <on-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 [Any + (if export? + (' {#.export? #1}) + (' {})) + []]))] + (//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> (^ (#error.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 [expectedT (' {}) []])] + (//type.with-inference + (_primitive.phase (code.identifier def-name)))) + (//module.with-module 0 def-module) + (///.run _primitive.state) + (case> (^ (#error.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 new file mode 100644 index 000000000..7c7e9e52c --- /dev/null +++ b/stdlib/source/test/lux/tool/compiler/phase/analysis/structure.lux @@ -0,0 +1,303 @@ +(.module: + [lux #* + [abstract ["." monad (#+ do)]] + [data + text/format + ["." name]] + ["r" math/random (#+ Random) ("#@." monad)] + ["_" test (#+ Test)] + [control + pipe] + [data + ["." bit ("#@." equivalence)] + ["." error] + ["." product] + ["." maybe] + ["." text] + [collection + ["." list ("#@." functor)] + ["." set]]] + ["." type + ["." check]] + [macro + ["." code]]] + [// + ["_." primitive]] + {1 + ["." / + ["/#" // + ["#." module] + ["#." type] + ["/#" // + ["/#" // + ["#." analysis (#+ Analysis Variant Tag Operation)]]]]]}) + +(template [<name> <on-success> <on-error>] + [(def: #export <name> + (All [a] (-> (Operation a) Bit)) + (|>> (///.run _primitive.state) + (case> (#error.Success _) + <on-success> + + _ + <on-error>)))] + + [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> (^ (#error.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> (^ (#error.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> (#error.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> (^ (#error.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> (#error.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> (#error.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> (#error.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/common.lux b/stdlib/source/test/lux/tool/compiler/phase/extension/analysis/common.lux new file mode 100644 index 000000000..9c9d675fd --- /dev/null +++ b/stdlib/source/test/lux/tool/compiler/phase/extension/analysis/common.lux @@ -0,0 +1,202 @@ +(.module: + [lux (#- i64 int primitive) + [abstract ["." monad (#+ do)]] + [data + text/format + ["." name]] + ["r" math/random (#+ Random) ("#@." monad)] + ["_" test (#+ Test)] + [control + pipe + [io (#+ IO)] + [concurrency + ["." atom]]] + [data + ["." error] + ["." product]] + ["." type ("#@." equivalence)] + [macro + ["." code]]] + [//// + [analysis + ["_." primitive]]] + {1 + ["." / + ["///#" //// + [analysis + ["#." scope] + ["#." type]]]]}) + +(template [<name> <success> <failure>] + [(def: (<name> 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> (#error.Success _) + <success> + + (#error.Failure error) + <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 coerce" (~ (type.to-code (type (IO primT)))) + ([(~' _) (~' _)] (~ primC))))) + (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 int *" (list paramC subjectC) Int)) + (_.test "Can divide integers." + (check-success+ "lux int /" (list paramC subjectC) Int)) + (_.test "Can calculate remainder of integers." + (check-success+ "lux int %" (list paramC subjectC) Int)) + (_.test "Can compare integers." + (check-success+ "lux int <" (list paramC subjectC) Bit)) + (_.test "Can convert integer to text." + (check-success+ "lux int char" (list subjectC) Text)) + (_.test "Can convert integer to fraction." + (check-success+ "lux int frac" (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 (|>> %f code.text)))] + ($_ _.and + (_.test "Can add frac numbers." + (check-success+ "lux frac +" (list paramC subjectC) Frac)) + (_.test "Can subtract frac numbers." + (check-success+ "lux frac -" (list paramC subjectC) Frac)) + (_.test "Can multiply frac numbers." + (check-success+ "lux frac *" (list paramC subjectC) Frac)) + (_.test "Can divide frac numbers." + (check-success+ "lux frac /" (list paramC subjectC) Frac)) + (_.test "Can calculate remainder of frac numbers." + (check-success+ "lux frac %" (list paramC subjectC) Frac)) + (_.test "Can test equivalence of frac numbers." + (check-success+ "lux frac =" (list paramC subjectC) Bit)) + (_.test "Can compare frac numbers." + (check-success+ "lux frac <" (list paramC subjectC) Bit)) + (_.test "Can obtain minimum frac number." + (check-success+ "lux frac min" (list) Frac)) + (_.test "Can obtain maximum frac number." + (check-success+ "lux frac max" (list) Frac)) + (_.test "Can obtain smallest frac number." + (check-success+ "lux frac smallest" (list) Frac)) + (_.test "Can convert frac number to integer." + (check-success+ "lux frac int" (list subjectC) Int)) + (_.test "Can convert frac number to text." + (check-success+ "lux frac encode" (list subjectC) Text)) + (_.test "Can convert text to frac number." + (check-success+ "lux frac 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 + ))) |