1 files changed, 277 insertions, 0 deletions
diff --git a/stdlib/source/lux/lang/synthesis/loop.lux b/stdlib/source/lux/lang/synthesis/loop.lux
new file mode 100644
index 000000000..476cf27b4
--- /dev/null
+++ b/stdlib/source/lux/lang/synthesis/loop.lux
@@ -0,0 +1,277 @@
+(.module:
+  [lux #- loop]
+  (lux (control [monad #+ do]
+                ["p" parser])
+       (data [maybe "maybe/" Monad<Maybe>]
+             (coll [list "list/" Functor<List>]))
+       (macro [code]
+              [syntax]))
+  [///analysis #+ Register Variable Environment]
+  [// #+ Path Abstraction Synthesis])
+
+(type: (Transform a)
+  (-> a (Maybe a)))
+
+(def: (some? maybe)
+  (All [a] (-> (Maybe a) Bool))
+  (case maybe
+    (#.Some _) true
+    #.None     false))
+
+(def: proper Bool true)
+
+(def: (proper? exprS)
+  (-> Synthesis Bool)
+  (case exprS
+    (#//.Structure structure)
+    (case structure
+      (#//.Variant variantS)
+      (proper? (get@ #///analysis.value variantS))
+      
+      (#//.Tuple membersS+)
+      (list.every? proper? membersS+))
+
+    (#//.Variable var)
+    (not (///analysis.self? var))
+
+    (#//.Control controlS)
+    (case controlS
+      (#//.Branch branchS)
+      (case branchS
+        (#//.Case inputS pathS)
+        (and (proper? inputS)
+             (.loop [pathS pathS]
+               (case pathS
+                 (^or (#//.Alt leftS rightS) (#//.Seq leftS rightS))
+                 (and (recur leftS) (recur rightS))
+
+                 (#//.Exec bodyS)
+                 (proper? bodyS)
+                 
+                 _
+                 proper)))
+
+        (#//.Let inputS register bodyS)
+        (and (proper? inputS)
+             (proper? bodyS))
+
+        (#//.If inputS thenS elseS)
+        (and (proper? inputS)
+             (proper? thenS)
+             (proper? elseS)))
+
+      (#//.Loop loopS)
+      (case loopS
+        (#//.Scope scopeS)
+        (and (list.every? proper? (get@ #//.inits scopeS))
+             (proper? (get@ #//.iteration scopeS)))
+
+        (#//.Recur argsS)
+        (list.every? proper? argsS))
+
+      (#//.Function functionS)
+      (case functionS
+        (#//.Abstraction environment arity bodyS)
+        (list.every? ///analysis.self? environment)
+
+        (#//.Apply funcS argsS)
+        (and (proper? funcS)
+             (list.every? proper? argsS))))
+
+    (#//.Special [special argsS])
+    (list.every? proper? argsS)
+
+    _
+    proper))
+
+(def: (path-recursion synthesis-recursion)
+  (-> (Transform Synthesis) (Transform Path))
+  (function (recur pathS)
+    (case pathS
+      (#//.Alt leftS rightS)
+      (let [leftS' (recur leftS)
+            rightS' (recur rightS)]
+        (if (or (some? leftS')
+                (some? rightS'))
+          (#.Some (#//.Alt (maybe.default leftS leftS')
+                           (maybe.default rightS rightS')))
+          #.None))
+      
+      (#//.Seq leftS rightS)
+      (maybe/map (|>> (#//.Seq leftS)) (recur rightS))
+
+      (#//.Exec bodyS)
+      (maybe/map (|>> #//.Exec) (synthesis-recursion bodyS))
+      
+      _
+      #.None)))
+
+(template: (recursive-apply args)
+  (#//.Apply (#//.Variable (#///analysis.Local +0))
+             args))
+
+(def: #export (recursion arity)
+  (-> Nat (Transform Synthesis))
+  (function (recur exprS)
+    (case exprS
+      (#//.Control controlS)
+      (case controlS
+        (#//.Branch branchS)
+        (case branchS
+          (#//.Case inputS pathS)
+          (|> pathS
+              (path-recursion recur)
+              (maybe/map (|>> (#//.Case inputS) #//.Branch #//.Control)))
+
+          (#//.Let inputS register bodyS)
+          (maybe/map (|>> (#//.Let inputS register) #//.Branch #//.Control)
+                     (recur bodyS))
+
+          (#//.If inputS thenS elseS)
+          (let [thenS' (recur thenS)
+                elseS' (recur elseS)]
+            (if (or (some? thenS')
+                    (some? elseS'))
+              (#.Some (|> (#//.If inputS
+                                  (maybe.default thenS thenS')
+                                  (maybe.default elseS elseS'))
+                          #//.Branch #//.Control))
+              #.None)))
+
+        (^ (#//.Function (recursive-apply argsS)))
+        (if (n/= arity (list.size argsS))
+          (#.Some (|> argsS #//.Recur #//.Loop #//.Control))
+          #.None)
+
+        _
+        #.None)
+
+      _
+      #.None)))
+
+(def: (resolve environment)
+  (-> Environment (Transform Variable))
+  (function (_ variable)
+    (case variable
+      (#///analysis.Foreign register)
+      (list.nth register environment)
+
+      _
+      (#.Some variable))))
+
+(def: (adjust-path adjust-synthesis offset)
+  (-> (Transform Synthesis) Register (Transform Path))
+  (function (recur pathS)
+    (case pathS
+      (#//.Bind register)
+      (#.Some (#//.Bind (n/+ offset register)))
+
+      (^template [<tag>]
+        (<tag> leftS rightS)
+        (do maybe.Monad<Maybe>
+          [leftS' (recur leftS)
+           rightS' (recur rightS)]
+          (wrap (<tag> leftS' rightS'))))
+      ([#//.Alt] [#//.Seq])
+      
+      (#//.Exec bodyS)
+      (|> bodyS adjust-synthesis (maybe/map (|>> #//.Exec)))
+
+      _
+      (#.Some pathS))))
+
+(def: (adjust scope-environment offset)
+  (-> Environment Register (Transform Synthesis))
+  (function (recur exprS)
+    (case exprS
+      (#//.Structure structureS)
+      (case structureS
+        (#//.Variant variantS)
+        (do maybe.Monad<Maybe>
+          [valueS' (|> variantS (get@ #///analysis.value) recur)]
+          (wrap (|> variantS
+                    (set@ #///analysis.value valueS')
+                    #//.Variant
+                    #//.Structure)))
+        
+        (#//.Tuple membersS+)
+        (|> membersS+
+            (monad.map maybe.Monad<Maybe> recur)
+            (maybe/map (|>> #//.Tuple #//.Structure))))
+
+      (#//.Variable variable)
+      (case variable
+        (#///analysis.Local register)
+        (#.Some (#//.Variable (#///analysis.Local (n/+ offset register))))
+        
+        (#///analysis.Foreign register)
+        (|> scope-environment
+            (list.nth register)
+            (maybe/map (|>> #//.Variable))))
+
+      (^ (//.branch/case [inputS pathS]))
+      (do maybe.Monad<Maybe>
+        [inputS' (recur inputS)
+         pathS' (adjust-path recur offset pathS)]
+        (wrap (|> pathS' [inputS'] //.branch/case)))
+
+      (^ (//.branch/let [inputS register bodyS]))
+      (do maybe.Monad<Maybe>
+        [inputS' (recur inputS)
+         bodyS' (recur bodyS)]
+        (wrap (//.branch/let [inputS' register bodyS'])))
+
+      (^ (//.branch/if [inputS thenS elseS]))
+      (do maybe.Monad<Maybe>
+        [inputS' (recur inputS)
+         thenS' (recur thenS)
+         elseS' (recur elseS)]
+        (wrap (//.branch/if [inputS' thenS' elseS'])))
+
+      (^ (//.loop/scope scopeS))
+      (do maybe.Monad<Maybe>
+        [inits' (|> scopeS
+                    (get@ #//.inits)
+                    (monad.map maybe.Monad<Maybe> recur))
+         iteration' (recur (get@ #//.iteration scopeS))]
+        (wrap (//.loop/scope {#//.start (|> scopeS (get@ #//.start) (n/+ offset))
+                              #//.inits inits'
+                              #//.iteration iteration'})))
+
+      (^ (//.loop/recur argsS))
+      (|> argsS
+          (monad.map maybe.Monad<Maybe> recur)
+          (maybe/map (|>> //.loop/recur)))
+      
+
+      (^ (//.function/abstraction [environment arity bodyS]))
+      (do maybe.Monad<Maybe>
+        [environment' (monad.map maybe.Monad<Maybe>
+                                 (resolve scope-environment)
+                                 environment)]
+        (wrap (//.function/abstraction [environment' arity bodyS])))
+      
+      (^ (//.function/apply [function arguments]))
+      (do maybe.Monad<Maybe>
+        [function' (recur function)
+         arguments' (monad.map maybe.Monad<Maybe> recur arguments)]
+        (wrap (//.function/apply [function' arguments'])))
+
+      (#//.Special [procedure argsS])
+      (|> argsS
+          (monad.map maybe.Monad<Maybe> recur)
+          (maybe/map (|>> [procedure] #//.Special)))
+
+      _
+      (#.Some exprS))))
+
+(def: #export (loop environment num-locals inits functionS)
+  (-> Environment Nat (List Synthesis) Abstraction (Maybe Synthesis))
+  (let [bodyS (get@ #//.body functionS)]
+    (if (and (n/= (list.size inits)
+                  (get@ #//.arity functionS))
+             (proper? bodyS))
+      (|> bodyS
+          (adjust environment num-locals)
+          (maybe/map (|>> [(inc num-locals) inits] //.loop/scope)))
+      #.None)))