From 084e3c400410e954b633a07c98f32ecfa62f1ec8 Mon Sep 17 00:00:00 2001
From: Eduardo Julian
Date: Fri, 26 Apr 2019 21:37:40 -0400
Subject: Ported reference tests.

---
 stdlib/source/spec/compositor.lux                  | 65 +++++++++++++++-------
 .../spec/compositor/generation/reference.lux       | 56 +++++++++++++++++++
 2 files changed, 101 insertions(+), 20 deletions(-)
 create mode 100644 stdlib/source/spec/compositor/generation/reference.lux

(limited to 'stdlib/source')

diff --git a/stdlib/source/spec/compositor.lux b/stdlib/source/spec/compositor.lux
index bb90b0cdf..a62d2efa9 100644
--- a/stdlib/source/spec/compositor.lux
+++ b/stdlib/source/spec/compositor.lux
@@ -8,6 +8,7 @@
     ["." error (#+ Error)]]
    [tool
     [compiler
+     ["." reference]
      ["." synthesis (#+ Synthesis)]
      ["." statement]
      ["." phase
@@ -21,28 +22,11 @@
 (type: #export Runner (-> Text Synthesis (Error Any)))
 (type: #export Definer (-> Name Synthesis (Error Any)))
 
-(def: #export (runner platform bundle expander program)
+(type: #export (Instancer what)
   (All [anchor expression statement]
     (-> (Platform IO anchor expression statement)
-        (Bundle anchor expression statement)
-        Expander
-        (-> expression statement)
-        Runner))
-  (function (_ evaluation-name expressionS)
-    (io.run
-     (do io.monad
-       [?state (platform.initialize expander platform bundle program)]
-       (wrap (do error.monad
-               [[bundle' state] ?state
-                expressionG (<| (phase.run (get@ [#statement.generation
-                                                  #statement.state]
-                                                 state))
-                                (do phase.monad
-                                  [_ (get@ #platform.runtime platform)]
-                                  ((get@ #platform.phase platform) expressionS)))]
-               (:: (get@ #platform.host platform) evaluate! evaluation-name
-                   expressionG)))))
-    ))
+        (generation.State+ anchor expression statement)
+        what)))
 
 ## (def: #export (runner generate-runtime translate bundle state)
 ##   (-> (Operation Any) Phase Bundle (IO State)
@@ -55,6 +39,16 @@
 ##         translation.with-buffer
 ##         (phase.run [bundle (io.run state)]))))
 
+(def: (runner (^slots [#platform.runtime #platform.phase #platform.host]) state)
+  (Instancer Runner)
+  (function (_ evaluation-name expressionS)
+    (do error.monad
+      [expressionG (<| (phase.run state)
+                       (do phase.monad
+                         [_ runtime]
+                         (phase expressionS)))]
+      (:: host evaluate! evaluation-name expressionG))))
+
 ## (def: #export (definer generate-runtime translate bundle state)
 ##   (-> (Operation Any) Phase Bundle (IO State) Definer)
 ##   (function (_ lux-name valueS)
@@ -67,3 +61,34 @@
 ##           (translation.evaluate! "definer" program))
 ##         translation.with-buffer
 ##         (phase.run [bundle (io.run state)]))))
+
+(def: (definer (^slots [#platform.runtime #platform.phase #platform.host])
+               state)
+  (Instancer Definer)
+  (function (_ lux-name expressionS)
+    (do error.monad
+      [definitionG (<| (phase.run state)
+                       (do phase.monad
+                         [_ runtime
+                          expressionG (phase expressionS)
+                          [host-name host-value host-statement] (generation.define! lux-name expressionG)
+                          _ (generation.learn lux-name host-name)]
+                         (phase (synthesis.constant lux-name))))]
+      (:: host evaluate! "definer" definitionG))))
+
+(def: #export (executors platform bundle expander program)
+  (All [anchor expression statement]
+    (-> (Platform IO anchor expression statement)
+        (Bundle anchor expression statement)
+        Expander
+        (-> expression statement)
+        (IO (Error [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)])))))
diff --git a/stdlib/source/spec/compositor/generation/reference.lux b/stdlib/source/spec/compositor/generation/reference.lux
new file mode 100644
index 000000000..35de4e8ef
--- /dev/null
+++ b/stdlib/source/spec/compositor/generation/reference.lux
@@ -0,0 +1,56 @@
+(.module:
+  [lux #*
+   ["_" test (#+ Test)]
+   [abstract
+    [monad (#+ do)]]
+   [control
+    [pipe (#+ case>)]]
+   [data
+    ["." error]]
+   [tool
+    [compiler
+     ["." reference]
+     ["." synthesis]]]
+   [math
+    ["r" random (#+ Random)]]]
+  ["." ///])
+
+(def: name
+  (Random Name)
+  (let [name-part (r.ascii/upper-alpha 5)]
+    [(r.and name-part name-part)]))
+
+(def: (definition define)
+  (-> ///.Definer Test)
+  (do r.monad
+    [name ..name
+     expected r.safe-frac]
+    (_.test "Definitions."
+            (|> (define name (synthesis.f64 expected))
+                (case> (#error.Success actual)
+                       (f/= expected (:coerce Frac actual))
+
+                       (#error.Failure error)
+                       false)))))
+
+(def: (variable run)
+  (-> ///.Runner Test)
+  (do r.monad
+    [register (|> r.nat (:: @ map (n/% 100)))
+     expected r.safe-frac]
+    (_.test "Local variables."
+            (|> (synthesis.branch/let [(synthesis.f64 expected)
+                                       register
+                                       (synthesis.variable/local register)])
+                (run "variable")
+                (case> (#error.Success actual)
+                       (f/= expected (:coerce Frac actual))
+
+                       (#error.Failure error)
+                       false)))))
+
+(def: #export (spec runner definer)
+  (-> ///.Runner ///.Definer Test)
+  ($_ _.and
+      (..definition definer)
+      (..variable runner)))
-- 
cgit v1.2.3