Ported tests for type analysis.

1 files changed, 67 insertions, 0 deletions

diff --git a/stdlib/source/spec/compositor/analysis/type.lux b/stdlib/source/spec/compositor/analysis/type.lux
new file mode 100644
index 000000000..a6105bbde
--- /dev/null
+++ b/stdlib/source/spec/compositor/analysis/type.lux
@@ -0,0 +1,67 @@
+(.module:
+  [lux #*
+   ["_" test (#+ Test)]
+   ["." type ("#@." equivalence)]
+   [abstract
+    [monad (#+ do)]]
+   [control
+    [pipe (#+ case>)]
+    ["." io]]
+   [data
+    ["." error]
+    ["." bit ("#@." equivalence)]
+    ["." text ("#@." equivalence)]]
+   [math
+    ["r" random (#+ Random)]]
+   [macro
+    ["." code]]
+   [tool
+    [compiler
+     [analysis (#+ State+)]
+     ["." phase
+      [macro (#+ Expander)]
+      ["." analysis
+       ["#/." scope]
+       ["#/." type]]]]]])
+
+(def: (check-success+ expander state extension params output-type)
+  (-> Expander State+ Text (List Code) Type Bit)
+  (|> (analysis/scope.with-scope ""
+        (analysis/type.with-type output-type
+          (analysis.phase expander (` ((~ (code.text extension)) (~+ params))))))
+      (phase.run state)
+      (case> (#error.Success _)
+             true
+
+             (#error.Failure error)
+             false)))
+
+(def: check
+  (Random [Code Type Code])
+  (`` ($_ r.either
+          (~~ (template [<random> <type> <code>]
+                [(do r.monad
+                   [value <random>]
+                   (wrap [(` <type>)
+                          <type>
+                          (<code> value)]))]
+
+                [r.bit (0 "#Bit" (0)) code.bit]
+                [r.nat (0 "#I64" (1 (0 "#Nat" (0)) (0))) code.nat]
+                [r.int (0 "#I64" (1 (0 "#Int" (0)) (0))) code.int]
+                [r.rev (0 "#I64" (1 (0 "#Rev" (0)) (0))) code.rev]
+                [r.safe-frac (0 "#Frac" (0)) code.frac]
+                [(r.ascii/upper-alpha 5) (0 "#Text" (0)) code.text]
+                )))))
+
+(def: #export (spec expander state)
+  (-> Expander State+ Test)
+  (do r.monad
+    [[typeC exprT exprC] ..check
+     [other-typeC other-exprT other-exprC] ..check]
+    ($_ _.and
+        (_.test "lux check"
+                (check-success+ expander state "lux check" (list typeC exprC) exprT))
+        (_.test "lux coerce"
+                (check-success+ expander state "lux coerce" (list typeC other-exprC) exprT))
+        )))