- Function generation.

5 files changed, 102 insertions, 6 deletions

diff --git a/new-luxc/test/test/luxc/common.lux b/new-luxc/test/test/luxc/common.lux
index 161675075..7c1444e01 100644
--- a/new-luxc/test/test/luxc/common.lux
+++ b/new-luxc/test/test/luxc/common.lux
@@ -4,7 +4,8 @@
        ["r" math/random "r/" Monad<Random>]
        (data ["R" result])
        [macro]
-       (macro [code]))
+       (macro [code])
+       [io])
   (luxc ["&" base]
         [analyser]
         ["&;" host]))
@@ -32,4 +33,4 @@
    #;expected        #;None
    #;seed            +0
    #;scope-type-vars (list)
-   #;host            (:! Void (&host;init-host []))})
+   #;host            (:! Void (io;run &host;init-host))})
diff --git a/new-luxc/test/test/luxc/generator/function.lux b/new-luxc/test/test/luxc/generator/function.lux
new file mode 100644
index 000000000..76ab600fe
--- /dev/null
+++ b/new-luxc/test/test/luxc/generator/function.lux
@@ -0,0 +1,96 @@
+(;module:
+  lux
+  (lux [io]
+       (control [monad #+ do]
+                pipe)
+       (data text/format
+             [product]
+             ["R" result]
+             [bool "B/" Eq<Bool>]
+             [text "T/" Eq<Text>]
+             (coll ["a" array]
+                   [list "L/" Functor<List>]
+                   ["S" set]))
+       ["r" math/random "r/" Monad<Random>]
+       [macro #+ Monad<Lux>]
+       (macro [code])
+       [host]
+       test)
+  (luxc (lang ["ls" synthesis])
+        [analyser]
+        [synthesizer]
+        (generator ["@;" expr]
+                   ["@;" eval]
+                   ["@;" runtime]
+                   ["@;" common]))
+  (test/luxc common))
+
+(def: arity-limit Nat +10)
+
+(def: arity
+  (r;Random ls;Arity)
+  (|> r;nat (r/map (|>. (n.% arity-limit) (n.max +1)))))
+
+(def: gen-function
+  (r;Random [ls;Arity Nat ls;Synthesis])
+  (do r;Monad<Random>
+    [arity arity
+     arg (|> r;nat (:: @ map (n.% arity)))
+     #let [functionS (#ls;Function arity (list) (#ls;Variable (nat-to-int (n.inc arg))))]]
+    (wrap [arity arg functionS])))
+
+(context: "Function."
+  [[arity arg functionS] gen-function
+   cut-off (|> r;nat (:: @ map (n.% arity)))
+   args (r;list arity r;nat)
+   #let [arg-value (assume (list;nth arg args))
+         argsS (L/map (|>. #ls;Nat) args)
+         last-arg (n.dec arity)
+         cut-off (|> cut-off (n.min (n.dec last-arg)))]]
+  ($_ seq
+      (test "Can read arguments."
+            (|> (do Monad<Lux>
+                  [runtime-bytecode @runtime;generate]
+                  (@eval;eval (@expr;generate (#ls;Call argsS functionS))))
+                (macro;run (init-compiler []))
+                (case> (#R;Success valueG)
+                       (n.= arg-value (:! Nat valueG))
+
+                       (#R;Error error)
+                       false)))
+      (test "Can partially apply functions."
+            (or (n.= +1 arity)
+                (|> (do Monad<Lux>
+                      [#let [partial-arity (n.inc cut-off)
+                             preS (list;take partial-arity argsS)
+                             postS (list;drop partial-arity argsS)]
+                       runtime-bytecode @runtime;generate]
+                      (@eval;eval (@expr;generate (|> functionS (#ls;Call preS) (#ls;Call postS)))))
+                    (macro;run (init-compiler []))
+                    (case> (#R;Success valueG)
+                           (n.= arg-value (:! Nat valueG))
+
+                           (#R;Error error)
+                           false))))
+      (test "Can read environment."
+            (or (n.= +1 arity)
+                (|> (do Monad<Lux>
+                      [#let [env (|> (list;n.range +0 cut-off)
+                                     (L/map (|>. n.inc nat-to-int)))
+                             super-arity (n.inc cut-off)
+                             arg-var (if (n.<= cut-off arg)
+                                       (|> arg n.inc nat-to-int (i.* -1))
+                                       (|> arg n.inc (n.- super-arity) nat-to-int))
+                             sub-arity (|> arity (n.- super-arity))
+                             functionS (<| (#ls;Function super-arity (list))
+                                           (#ls;Function sub-arity env)
+                                           (#ls;Variable arg-var))]
+                       runtime-bytecode @runtime;generate]
+                      (@eval;eval (@expr;generate (#ls;Call argsS functionS))))
+                    (macro;run (init-compiler []))
+                    (case> (#R;Success valueG)
+                           (n.= arg-value (:! Nat valueG))
+
+                           (#R;Error error)
+                           false))))
+      ))
diff --git a/new-luxc/test/test/luxc/synthesizer/function.lux b/new-luxc/test/test/luxc/synthesizer/function.lux
index 7257307dc..6791eceb4 100644
--- a/new-luxc/test/test/luxc/synthesizer/function.lux
+++ b/new-luxc/test/test/luxc/synthesizer/function.lux
@@ -142,7 +142,7 @@
   ($_ seq
       (test "Can synthesize function application."
             (|> (synthesizer;synthesize (la;apply argsA funcA))
-                (case> (#ls;Call funcS argsS)
+                (case> (#ls;Call argsS funcS)
                        (and (corresponds? funcA funcS)
                             (list;every? (product;uncurry corresponds?)
                                          (list;zip2 argsA argsS)))
diff --git a/new-luxc/test/test/luxc/synthesizer/loop.lux b/new-luxc/test/test/luxc/synthesizer/loop.lux
index 45b86ede6..849df78d4 100644
--- a/new-luxc/test/test/luxc/synthesizer/loop.lux
+++ b/new-luxc/test/test/luxc/synthesizer/loop.lux
@@ -157,7 +157,7 @@
               (and (n.= arity (list;size _inits))
                    (not (&&loop;contains-self-reference? _body)))
 
-              (#ls;Call (#ls;Function _arity _env _bodyS) argsS)
+              (#ls;Call argsS (#ls;Function _arity _env _bodyS))
               (&&loop;contains-self-reference? _bodyS)
 
               _
diff --git a/new-luxc/test/tests.lux b/new-luxc/test/tests.lux
index d07822069..30fab3878 100644
--- a/new-luxc/test/tests.lux
+++ b/new-luxc/test/tests.lux
@@ -21,11 +21,10 @@
               (generator ["_;G" primitive]
                          ["_;G" structure]
                          ["_;G" case]
+                         ["_;G" function]
                          (procedure ["_;G" common]))
               ))
-  ## (luxc (generator ["_;G" function]))
   )
 
-## [Program]
 (program: args
   (test;run))