aboutsummaryrefslogtreecommitdiff
path: root/stdlib
diff options
context:
space:
mode:
Diffstat (limited to 'stdlib')
-rw-r--r--stdlib/source/lux/data/name.lux19
-rw-r--r--stdlib/source/lux/tool/compiler/default/syntax.lux31
-rw-r--r--stdlib/source/lux/tool/compiler/phase/analysis/reference.lux18
-rw-r--r--stdlib/source/lux/tool/compiler/phase/extension/analysis/common.lux2
-rw-r--r--stdlib/source/lux/type.lux78
-rw-r--r--stdlib/source/test/lux.lux6
-rw-r--r--stdlib/source/test/lux/compiler/default/phase/analysis/case.lux198
-rw-r--r--stdlib/source/test/lux/compiler/default/phase/analysis/function.lux118
-rw-r--r--stdlib/source/test/lux/compiler/default/phase/analysis/primitive.lux100
-rw-r--r--stdlib/source/test/lux/compiler/default/phase/analysis/procedure/common.lux187
-rw-r--r--stdlib/source/test/lux/compiler/default/phase/analysis/reference.lux107
-rw-r--r--stdlib/source/test/lux/compiler/default/phase/analysis/structure.lux297
-rw-r--r--stdlib/source/test/lux/tool.lux13
-rw-r--r--stdlib/source/test/lux/tool/compiler/default/syntax.lux30
-rw-r--r--stdlib/source/test/lux/tool/compiler/phase/analysis.lux24
-rw-r--r--stdlib/source/test/lux/tool/compiler/phase/analysis/case.lux201
-rw-r--r--stdlib/source/test/lux/tool/compiler/phase/analysis/function.lux125
-rw-r--r--stdlib/source/test/lux/tool/compiler/phase/analysis/primitive.lux108
-rw-r--r--stdlib/source/test/lux/tool/compiler/phase/analysis/reference.lux106
-rw-r--r--stdlib/source/test/lux/tool/compiler/phase/analysis/structure.lux303
-rw-r--r--stdlib/source/test/lux/tool/compiler/phase/extension/analysis/common.lux202
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
+ )))