Now applying the loop optimization to all functions.

4 files changed, 116 insertions, 86 deletions

diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/synthesis.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/synthesis.lux
index 44b627b6c..33e94f89a 100644
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/synthesis.lux
+++ b/stdlib/source/lux/tool/compiler/language/lux/phase/synthesis.lux
@@ -50,42 +50,46 @@
       (phase@wrap (#/.Primitive (..primitive analysis')))
 
       (#///analysis.Structure structure)
-      (case structure
-        (#///analysis.Variant variant)
-        (do phase.monad
-          [valueS (phase' (get@ #///analysis.value variant))]
-          (wrap (/.variant (set@ #///analysis.value valueS variant))))
+      (/.with-currying? false
+        (case structure
+          (#///analysis.Variant variant)
+          (do phase.monad
+            [valueS (phase' (get@ #///analysis.value variant))]
+            (wrap (/.variant (set@ #///analysis.value valueS variant))))
 
-        (#///analysis.Tuple tuple)
-        (|> tuple
-            (monad.map phase.monad phase')
-            (phase@map (|>> /.tuple))))
+          (#///analysis.Tuple tuple)
+          (|> tuple
+              (monad.map phase.monad phase')
+              (phase@map (|>> /.tuple)))))
       
       (#///analysis.Reference reference)
       (phase@wrap (#/.Reference reference))
 
       (#///analysis.Case inputA branchesAB+)
-      (/case.synthesize phase branchesAB+ archive inputA)
+      (/.with-currying? false
+        (/case.synthesize phase branchesAB+ archive inputA))
 
       (^ (///analysis.no-op value))
       (phase' value)
 
       (#///analysis.Apply _)
-      (/function.apply phase archive analysis)
+      (/.with-currying? false
+        (/function.apply phase archive analysis))
 
       (#///analysis.Function environmentA bodyA)
       (/function.abstraction phase environmentA archive bodyA)
 
       (#///analysis.Extension name args)
-      (function (_ state)
-        (|> (//extension.apply archive phase [name args])
-            (phase.run' state)
-            (case> (#try.Success output)
-                   (#try.Success output)
-                   
-                   (#try.Failure _)
-                   (<| (phase.run' state)
-                       (do {@ phase.monad}
-                         [argsS+ (monad.map @ phase' args)]
-                         (wrap (#/.Extension [name argsS+])))))))
+      (/.with-currying? false
+        (function (_ state)
+          (|> (//extension.apply archive phase [name args])
+              (phase.run' state)
+              (case> (#try.Success output)
+                     (#try.Success output)
+                     
+                     (#try.Failure _)
+                     (|> args
+                         (monad.map phase.monad phase')
+                         (phase@map (|>> [name] #/.Extension))
+                         (phase.run' state))))))
       )))
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/synthesis/function.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/synthesis/function.lux
index 890722aeb..358a63c31 100644
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/synthesis/function.lux
+++ b/stdlib/source/lux/tool/compiler/language/lux/phase/synthesis/function.lux
@@ -3,19 +3,20 @@
    [abstract
     ["." monad (#+ do)]]
    [control
-    [pipe (#+ case>)]
     ["." exception (#+ exception:)]]
    [data
     ["." maybe]
     ["." text
      ["%" format (#+ format)]]
+    [number
+     ["n" nat]]
     [collection
      ["." list ("#@." functor monoid fold)]]]]
   ["." // #_
    ["#." loop (#+ Transform)]
    ["//#" /// #_
     ["#." analysis (#+ Environment Analysis)]
-    ["/" synthesis (#+ Path Synthesis Operation Phase)]
+    ["/" synthesis (#+ Path Abstraction Synthesis Operation Phase)]
     [///
      [arity (#+ Arity)]
      ["#." reference
@@ -52,11 +53,14 @@
         (with-expansions [<apply> (as-is (/.function/apply [funcS argsS]))]
           (case funcS
             (^ (/.function/abstraction functionS))
-            (do @
-              [locals /.locals]
-              (wrap (|> functionS
-                        (//loop.optimization locals argsS)
-                        (maybe.default <apply>))))
+            (if (n.= (get@ #/.arity functionS)
+                     (list.size argsS))
+              (do @
+                [locals /.locals]
+                (wrap (|> functionS
+                          (//loop.optimization true locals argsS)
+                          (maybe.default <apply>))))
+              (wrap <apply>))
 
             (^ (/.function/apply [funcS' argsS']))
             (wrap (/.function/apply [funcS' (list@compose argsS' argsS)]))
@@ -211,13 +215,31 @@
 (def: #export (abstraction phase environment archive bodyA)
   (-> Phase Environment Phase)
   (do {@ phase.monad}
-    [bodyS (/.with-locals 2
-             (phase archive bodyA))]
-    (case bodyS
-      (^ (/.function/abstraction [env' down-arity' bodyS']))
-      (|> bodyS'
-          (grow env')
-          (:: @ map (|>> [environment (inc down-arity')] /.function/abstraction)))
-      
-      _
-      (wrap (/.function/abstraction [environment 1 bodyS])))))
+    [currying? /.currying?
+     bodyS (/.with-currying? true
+             (/.with-locals 2
+               (phase archive bodyA)))
+     abstraction (: (Operation Abstraction)
+                    (case bodyS
+                      (^ (/.function/abstraction [env' down-arity' bodyS']))
+                      (|> bodyS'
+                          (grow env')
+                          (:: @ map (function (_ body)
+                                      {#/.environment environment
+                                       #/.arity (inc down-arity')
+                                       #/.body body})))
+                      
+                      _
+                      (wrap {#/.environment environment
+                             #/.arity 1
+                             #/.body bodyS})))]
+    (wrap (if currying?
+            (/.function/abstraction abstraction)
+            (case (//loop.optimization false 1 (list) abstraction)
+              (#.Some loop-body)
+              (/.function/abstraction {#/.environment environment
+                                       #/.arity (get@ #/.arity abstraction)
+                                       #/.body loop-body})
+              
+              #.None
+              (/.function/abstraction abstraction))))))
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/synthesis/loop.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/synthesis/loop.lux
index b4a43ce23..9301292f8 100644
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/synthesis/loop.lux
+++ b/stdlib/source/lux/tool/compiler/language/lux/phase/synthesis/loop.lux
@@ -23,14 +23,18 @@
   (-> Register (-> Register Register))
   (|>> dec (n.+ offset)))
 
-(def: (variable-optimization offset environment variable)
-  (-> Register Environment (Transform Variable))
+(def: (variable-optimization true-loop? offset environment variable)
+  (-> Bit Register Environment (Transform Variable))
   (case variable
     (^ (variable.self))
-    #.None
+    (if true-loop?
+      #.None
+      (#.Some variable))
     
     (#variable.Foreign register)
-    (list.nth register environment)
+    (if true-loop?
+      (list.nth register environment)
+      (#.Some variable))
 
     (#variable.Local register)
     (#.Some (#variable.Local (register-optimization offset register)))))
@@ -58,8 +62,8 @@
       _
       (#.Some path))))
 
-(def: (body-optimization offset scope-environment arity expr)
-  (-> Register Environment Arity (Transform Synthesis))
+(def: (body-optimization true-loop? offset scope-environment arity expr)
+  (-> Bit Register Environment Arity (Transform Synthesis))
   (loop [return? true
          expr expr]
     (case expr
@@ -83,7 +87,9 @@
       (#/.Reference reference)
       (case reference
         (^ (#reference.Variable (variable.self)))
-        #.None
+        (if true-loop?
+          #.None
+          (#.Some expr))
         
         (^ (reference.constant constant))
         (#.Some expr)
@@ -92,9 +98,11 @@
         (#.Some (#/.Reference (reference.local (register-optimization offset register))))
 
         (^ (reference.foreign register))
-        (|> scope-environment
-            (list.nth register)
-            (maybe@map (|>> #reference.Variable #/.Reference))))
+        (if true-loop?
+          (|> scope-environment
+              (list.nth register)
+              (maybe@map (|>> /.variable)))
+          (#.Some expr)))
 
       (^ (/.branch/case [input path]))
       (do maybe.monad
@@ -137,35 +145,35 @@
 
       (^ (/.function/abstraction [environment arity body]))
       (do {@ maybe.monad}
-        [environment' (monad.map @ (variable-optimization offset scope-environment)
+        [environment' (monad.map @ (variable-optimization true-loop? offset scope-environment)
                                  environment)]
         (wrap (/.function/abstraction [environment' arity body])))
       
       (^ (/.function/apply [abstraction arguments]))
       (do {! maybe.monad}
         [arguments' (monad.map maybe.monad (recur false) arguments)]
-        (case abstraction
-          (^ (#/.Reference (#reference.Variable (variable.self))))
-          (if (and return?
-                   (n.= arity (list.size arguments)))
-            (wrap (/.loop/recur arguments'))
-            #.None)
-          
-          _
-          (do !
-            [abstraction' (recur false abstraction)]
-            (wrap (/.function/apply [abstraction' arguments'])))))
+        (with-expansions [<application> (as-is (do !
+                                                 [abstraction' (recur false abstraction)]
+                                                 (wrap (/.function/apply [abstraction' arguments']))))]
+          (case abstraction
+            (^ (#/.Reference (#reference.Variable (variable.self))))
+            (if (and return?
+                     (n.= arity (list.size arguments)))
+              (wrap (/.loop/recur arguments'))
+              (if true-loop?
+                #.None
+                <application>))
+            
+            _
+            <application>)))
 
       (#/.Extension [name args])
       (|> args
           (monad.map maybe.monad (recur false))
           (maybe@map (|>> [name] #/.Extension))))))
 
-(def: #export (optimization offset inits functionS)
-  (-> Register (List Synthesis) Abstraction (Maybe Synthesis))
-  (if (n.= (get@ #/.arity functionS)
-           (list.size inits))
-    (|> (get@ #/.body functionS)
-        (body-optimization offset (get@ #/.environment functionS) (get@ #/.arity functionS))
-        (maybe@map (|>> [offset inits] /.loop/scope)))
-    #.None))
+(def: #export (optimization true-loop? offset inits functionS)
+  (-> Bit Register (List Synthesis) Abstraction (Maybe Synthesis))
+  (|> (get@ #/.body functionS)
+      (body-optimization true-loop? offset (get@ #/.environment functionS) (get@ #/.arity functionS))
+      (maybe@map (|>> [offset inits] /.loop/scope))))
diff --git a/stdlib/source/lux/tool/compiler/language/lux/synthesis.lux b/stdlib/source/lux/tool/compiler/language/lux/synthesis.lux
index 06f84d90d..c010b05c3 100644
--- a/stdlib/source/lux/tool/compiler/language/lux/synthesis.lux
+++ b/stdlib/source/lux/tool/compiler/language/lux/synthesis.lux
@@ -27,10 +27,13 @@
     ["." reference (#+ Reference)
      ["." variable (#+ Register Variable)]]]])
 
-(type: #export Resolver (Dictionary Variable Variable))
+(type: #export Resolver
+  (Dictionary Variable Variable))
 
 (type: #export State
-  {#locals Nat})
+  {#locals Nat
+   ## https://en.wikipedia.org/wiki/Currying
+   #currying? Bit})
 
 (def: #export fresh-resolver
   Resolver
@@ -38,7 +41,8 @@
 
 (def: #export init
   State
-  {#locals 0})
+  {#locals 0
+   #currying? false})
 
 (type: #export Primitive
   (#Bit Bit)
@@ -180,25 +184,17 @@
 
 (def: #export unit Text "")
 
-(template [<name> <type> <tag>]
-  [(def: #export (<name> value)
+(template [<with> <query> <tag> <type>]
+  [(def: #export (<with> value)
      (-> <type> (All [a] (-> (Operation a) (Operation a))))
-     (extension.temporary (set@ <tag> value)))]
+     (extension.temporary (set@ <tag> value)))
 
-  [with-locals      Nat      #locals]
-  )
-
-(def: #export (with-abstraction arity resolver)
-  (-> Arity Resolver
-      (All [a] (-> (Operation a) (Operation a))))
-  (extension.with-state {#locals arity}))
-
-(template [<name> <tag> <type>]
-  [(def: #export <name>
+   (def: #export <query>
      (Operation <type>)
      (extension.read (get@ <tag>)))]
 
-  [locals      #locals      Nat]
+  [with-locals    locals    #locals    Nat]
+  [with-currying? currying? #currying? Bit]
   )
 
 (def: #export with-new-local