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.lux               | 31 +++++++-----
 stdlib/source/spec/compositor/analysis/type.lux | 67 +++++++++++++++++++++++++
 stdlib/source/spec/compositor/common.lux        | 17 ++++---
 3 files changed, 96 insertions(+), 19 deletions(-)
 create mode 100644 stdlib/source/spec/compositor/analysis/type.lux

(limited to 'stdlib/source/spec')

diff --git a/stdlib/source/spec/compositor.lux b/stdlib/source/spec/compositor.lux
index 5f46aad84..75818c3cf 100644
--- a/stdlib/source/spec/compositor.lux
+++ b/stdlib/source/spec/compositor.lux
@@ -11,6 +11,8 @@
     ["r" random]]
    [tool
     [compiler
+     ["." analysis]
+     ["." statement]
      [phase
       [macro (#+ Expander)]
       [generation (#+ Bundle)]]
@@ -18,6 +20,8 @@
       [platform (#+ Platform)]]]]]
   ["." / #_
    ["#." common (#+ Runner Definer)]
+   ["#./" analysis #_
+    ["#." type]]
    ["#./" generation #_
     ["#." primitive]
     ["#." structure]
@@ -26,9 +30,10 @@
     ["#." function]
     ["#." common]]])
 
-(def: (test runner definer)
-  (-> Runner Definer Test)
+(def: (test runner definer state expander)
+  (-> Runner Definer analysis.State+ Expander Test)
   ($_ _.and
+      (/analysis/type.spec expander state)
       (/generation/primitive.spec runner)
       (/generation/structure.spec runner)
       (/generation/reference.spec runner definer)
@@ -46,16 +51,18 @@
         Test))
   (do r.monad
     [_ (wrap [])
-     #let [?runner,definer (<| io.run
-                               (do io.monad
-                                 [platform platform])
-                               (/common.executors platform
-                                                  bundle
-                                                  expander
-                                                  program))]]
-    (case ?runner,definer
-      (#error.Success [runner definer])
-      (..test runner definer)
+     #let [?state,runner,definer (<| io.run
+                                     (do io.monad
+                                       [platform platform])
+                                     (/common.executors platform
+                                                        bundle
+                                                        expander
+                                                        program))]]
+    (case ?state,runner,definer
+      (#error.Success [[statement-bundle statement-state] runner definer])
+      (..test runner definer
+              (get@ [#statement.analysis #statement.state] statement-state)
+              expander)
 
       (#error.Failure error)
       (_.fail error))))
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