From ce71205758372cad17e09ac1b4b31dc4cea63528 Mon Sep 17 00:00:00 2001
From: Eduardo Julian
Date: Sat, 27 Apr 2019 01:03:52 -0400
Subject: Ported tests for type analysis.

---
 stdlib/source/spec/compositor/analysis/type.lux | 67 +++++++++++++++++++++++++
 stdlib/source/spec/compositor/common.lux        | 17 ++++---
 2 files changed, 77 insertions(+), 7 deletions(-)
 create mode 100644 stdlib/source/spec/compositor/analysis/type.lux

(limited to 'stdlib/source/spec/compositor')

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))
+        )))
diff --git a/stdlib/source/spec/compositor/common.lux b/stdlib/source/spec/compositor/common.lux
index 4967c0f8c..df332df57 100644
--- a/stdlib/source/spec/compositor/common.lux
+++ b/stdlib/source/spec/compositor/common.lux
@@ -60,13 +60,16 @@
         (Bundle anchor expression statement)
         Expander
         (-> expression statement)
-        (IO (Error [Runner Definer]))))
+        (IO (Error [(statement.State+ anchor expression statement)
+                    Runner
+                    Definer]))))
   (do io.monad
     [?state (platform.initialize expander platform bundle program)]
     (wrap (do error.monad
-            [[bundle' state] ?state
-             #let [state (get@ [#statement.generation
-                                #statement.state]
-                               state)]]
-            (wrap [(..runner platform state)
-                   (..definer platform state)])))))
+            [[statement-bundle statement-state] ?state
+             #let [generation-state (get@ [#statement.generation
+                                           #statement.state]
+                                          statement-state)]]
+            (wrap [[statement-bundle statement-state]
+                   (..runner platform generation-state)
+                   (..definer platform generation-state)])))))
-- 
cgit v1.2.3