- Refactored generic compiler infrastructure.

6 files changed, 128 insertions, 136 deletions

diff --git a/stdlib/source/lux/lang/compiler.lux b/stdlib/source/lux/lang/compiler.lux
new file mode 100644
index 000000000..c2f9af1e2
--- /dev/null
+++ b/stdlib/source/lux/lang/compiler.lux
@@ -0,0 +1,46 @@
+(.module:
+  lux
+  (lux (control [state]
+                ["ex" exception #+ Exception exception:]
+                [monad #+ do])
+       (data [product]
+             [error #+ Error])
+       [function]))
+
+(type: #export (Operation s o)
+  (state.State' Error s o))
+
+(def: #export (run state operation)
+  (All [s o]
+    (-> s (Operation s o) (Error o)))
+  (|> state
+      operation
+      (:: error.Monad<Error> map product.right)))
+
+(def: #export (throw exception parameters)
+  (All [e] (-> (Exception e) e Operation))
+  (state.lift error.Monad<Error>
+              (ex.throw exception parameters)))
+
+(def: #export (localized transform)
+  (All [s o]
+    (-> (-> s s)
+        (-> (Operation s o) (Operation s o))))
+  (function (_ operation)
+    (function (_ state)
+      (case (operation (transform state))
+        (#error.Error error)
+        (#error.Error error)
+
+        (#error.Success [state' output])
+        (#error.Success [state output])))))
+
+(def: #export (with-state state)
+  (All [s o] (-> s (-> (Operation s o) (Operation s o))))
+  (localized (function.constant state)))
+
+(def: #export Monad<Operation>
+  (state.Monad<State'> error.Monad<Error>))
+
+(type: #export (Compiler s i o)
+  (-> i (Operation s o)))
diff --git a/stdlib/source/lux/lang/extension.lux b/stdlib/source/lux/lang/extension.lux
index 6da453148..d9eb90fc9 100644
--- a/stdlib/source/lux/lang/extension.lux
+++ b/stdlib/source/lux/lang/extension.lux
@@ -7,8 +7,9 @@
              (coll (dictionary ["dict" unordered #+ Dict])))
        [macro])
   [// #+ Eval]
-  (// [".L" analysis #+ Analyser]
-      [".L" synthesis #+ Synthesizer]))
+  [//compiler #+ Operation Compiler]
+  [//analysis #+ Analyser]
+  [//synthesis #+ Synthesizer])
 
 (do-template [<name>]
   [(exception: #export (<name> {message Text})
@@ -26,11 +27,13 @@
   )
 
 (type: #export Analysis
-  (-> Analyser Eval (List Code) (Meta analysisL.Analysis)))
+  (-> Analyser Eval (List Code) (Meta //analysis.Analysis)))
 
 (type: #export Synthesis
-  (-> Synthesizer (List analysisL.Analysis)
-      (synthesisL.Operation synthesisL.Synthesis)))
+  (-> Synthesizer
+      (Compiler //synthesis.State
+                (List //analysis.Analysis)
+                //synthesis.Synthesis)))
 
 (type: #export Translation
   (-> (List Code) (Meta Code)))
diff --git a/stdlib/source/lux/lang/synthesis.lux b/stdlib/source/lux/lang/synthesis.lux
index d68b535dc..359ef445a 100644
--- a/stdlib/source/lux/lang/synthesis.lux
+++ b/stdlib/source/lux/lang/synthesis.lux
@@ -1,15 +1,11 @@
 (.module:
   [lux #- Scope]
-  (lux (control [state]
-                ["ex" exception #+ Exception exception:]
-                [monad #+ do])
-       (data [product]
-             [error #+ Error]
-             [number]
-             (coll (dictionary ["dict" unordered #+ Dict])))
-       [function])
+  (lux (control [monad #+ do])
+       (data [error #+ Error]
+             (coll (dictionary ["dict" unordered #+ Dict]))))
   [//reference #+ Register Variable Reference]
-  [//analysis #+ Environment Special Analysis])
+  [//analysis #+ Environment Special Analysis]
+  [//compiler #+ Operation Compiler])
 
 (type: #export Arity Nat)
 
@@ -32,12 +28,6 @@
    #direct? false
    #locals +0})
 
-(type: (Operation' s o)
-  (state.State' Error s o))
-
-(type: #export (Compiler s i o)
-  (-> i (Operation' ..State o)))
-
 (type: #export Primitive
   (#Bool Bool)
   (#I64 I64)
@@ -132,84 +122,42 @@
 (type: #export Abstraction
   (Abstraction' Synthesis))
 
-(type: #export (Operation a)
-  (Operation' ..State a))
-
 (def: #export unit Text "")
 
 (type: #export Synthesizer
   (Compiler ..State Analysis Synthesis))
 
-(def: #export (throw exception parameters)
-  (All [e] (-> (Exception e) e Operation'))
-  (state.lift error.Monad<Error>
-              (ex.throw exception parameters)))
-
-(def: #export (run synthesizer analysis)
-  (-> Synthesizer Analysis (Error Synthesis))
-  (:: error.Monad<Error> map product.right
-      (synthesizer analysis ..init)))
-
-(def: (localized' transform)
-  (-> (-> State State)
-      (All [a] (-> (Operation a) (Operation a))))
-  (function (_ operation)
-    (function (_ state)
-      (case (operation (transform state))
-        (#error.Error error)
-        (#error.Error error)
-
-        (#error.Success [state' output])
-        (#error.Success [state output])))))
-
-(def: (localized transform)
-  (-> (-> State State)
-      (-> Synthesizer Synthesizer))
-  (function (_ synthesize)
-    (function (_ analysis)
-      (localized' transform (synthesize analysis)))))
-
-(do-template [<operation> <synthesizer> <value>]
-  [(def: #export <operation>
-     (All [a] (-> (Operation a) (Operation a)))
-     (localized' (set@ #direct? <value>)))
-
-   (def: #export <synthesizer>
-     (-> Synthesizer Synthesizer)
-     (localized (set@ #direct? <value>)))]
-
-  [indirectly' indirectly false]
-  [directly'   directly   true]
-  )
+(do-template [<name> <value>]
+  [(def: #export <name>
+     (All [a] (-> (Operation ..State a) (Operation ..State a)))
+     (//compiler.localized (set@ #direct? <value>)))]
 
-(do-template [<operation> <synthesizer> <type> <tag>]
-  [(def: #export (<operation> value)
-     (-> <type> (All [a] (-> (Operation a) (Operation a))))
-     (localized' (set@ <tag> value)))
+  [indirectly false]
+  [directly   true]
+  )
 
-   (def: #export (<synthesizer> value)
-     (-> <type> (-> Synthesizer Synthesizer))
-     (localized (set@ <tag> value)))]
+(do-template [<name> <type> <tag>]
+  [(def: #export (<name> value)
+     (-> <type> (All [a] (-> (Operation ..State a) (Operation ..State a))))
+     (//compiler.localized (set@ <tag> value)))]
 
-  [with-scope-arity' with-scope-arity Arity    #scope-arity]
-  [with-resolver'    with-resolver    Resolver #resolver]
-  [with-locals'      with-locals      Nat      #locals]
+  [with-scope-arity Arity    #scope-arity]
+  [with-resolver    Resolver #resolver]
+  [with-locals      Nat      #locals]
   )
 
-(def: #export (with-state value)
-  (-> ..State (-> Synthesizer Synthesizer))
-  (localized (function.constant value)))
-
-(def: #export (with-abstraction-state arity resolver)
-  (-> Arity Resolver (-> Synthesizer Synthesizer))
-  (with-state {#scope-arity arity
-               #resolver resolver
-               #direct? true
-               #locals arity}))
+(def: #export (with-abstraction arity resolver)
+  (All [o]
+    (-> Arity Resolver
+        (-> (Operation ..State o) (Operation ..State o))))
+  (//compiler.with-state {#scope-arity arity
+                          #resolver resolver
+                          #direct? true
+                          #locals arity}))
 
 (do-template [<name> <tag> <type>]
   [(def: #export <name>
-     (Operation <type>)
+     (Operation ..State <type>)
      (function (_ state)
        (#error.Success [state (get@ <tag> state)])))]
 
@@ -219,13 +167,11 @@
   [locals      #locals      Nat]
   )
 
-(def: #export Operation@Monad (state.Monad<State'> error.Monad<Error>))
-
-(def: #export with-new-local'
-  (All [a] (-> (Operation a) (Operation a)))
-  (<<| (do Operation@Monad
+(def: #export with-new-local
+  (All [a] (-> (Operation ..State a) (Operation ..State a)))
+  (<<| (do //compiler.Monad<Operation>
          [locals ..locals])
-       (..with-locals' (inc locals))))
+       (..with-locals (inc locals))))
 
 (do-template [<name> <tag>]
   [(template: #export (<name> content)
diff --git a/stdlib/source/lux/lang/synthesis/case.lux b/stdlib/source/lux/lang/synthesis/case.lux
index 5fe32e62d..85065393d 100644
--- a/stdlib/source/lux/lang/synthesis/case.lux
+++ b/stdlib/source/lux/lang/synthesis/case.lux
@@ -10,12 +10,13 @@
              [number "frac/" Eq<Frac>]
              (coll [list "list/" Fold<List> Monoid<List>])))
   [///reference]
+  [///compiler #+ Operation "operation/" Monad<Operation>]
   [///analysis #+ Pattern Match Analysis]
-  [// #+ Path Synthesis Operation]
+  [// #+ Path Synthesis]
   [//function])
 
 (def: (path' pattern bodyC)
-  (-> Pattern (Operation Path) (Operation Path))
+  (-> Pattern (Operation //.State Path) (Operation //.State Path))
   (case pattern
     (#///analysis.Simple simple)
     (case simple
@@ -24,9 +25,8 @@
       
       (^template [<from> <to>]
         (<from> value)
-        (:: //.Operation@Monad map
-            (|>> (#//.Seq (#//.Test (|> value <to>))))
-            bodyC))
+        (operation/map (|>> (#//.Seq (#//.Test (|> value <to>))))
+                       bodyC))
       ([#///analysis.Bool #//.Bool]
        [#///analysis.Nat  (<| #//.I64 .i64)]
        [#///analysis.Int  (<| #//.I64 .i64)]
@@ -35,21 +35,21 @@
        [#///analysis.Text #//.Text]))
     
     (#///analysis.Bind register)
-    (do //.Operation@Monad
-      [arity //.scope-arity]
-      (:: @ map (|>> (#//.Seq (#//.Bind (if (//function.nested? arity)
-                                          (n/+ (dec arity) register)
-                                          register))))
-          (//.with-new-local' bodyC)))
+    (<| (do ///compiler.Monad<Operation>
+          [arity //.scope-arity])
+        (:: @ map (|>> (#//.Seq (#//.Bind (if (//function.nested? arity)
+                                            (n/+ (dec arity) register)
+                                            register)))))
+        //.with-new-local
+        bodyC)
 
     (#///analysis.Complex _)
     (case (///analysis.variant-pattern pattern)
       (#.Some [lefts right? value-pattern])
-      (:: //.Operation@Monad map
-          (|>> (#//.Seq (#//.Access (#//.Side (if right?
-                                                (#.Right lefts)
-                                                (#.Left lefts))))))
-          (path' value-pattern bodyC))
+      (operation/map (|>> (#//.Seq (#//.Access (#//.Side (if right?
+                                                           (#.Right lefts)
+                                                           (#.Left lefts))))))
+                     (path' value-pattern bodyC))
       
       #.None
       (let [tuple (///analysis.tuple-pattern pattern)
@@ -64,18 +64,17 @@
                          (|> (if (or last?
                                      (is? bodyC thenC))
                                thenC
-                               (:: //.Operation@Monad map (|>> (#//.Seq #//.Pop)) thenC))
+                               (operation/map (|>> (#//.Seq #//.Pop)) thenC))
                              (path' tuple/member)
-                             (:: //.Operation@Monad map
-                                 (|>> (#//.Seq (#//.Access (#//.Member (if last?
-                                                                         (#.Right (dec tuple/idx))
-                                                                         (#.Left tuple/idx)))))))))))
+                             (operation/map (|>> (#//.Seq (#//.Access (#//.Member (if last?
+                                                                                    (#.Right (dec tuple/idx))
+                                                                                    (#.Left tuple/idx)))))))))))
                    bodyC
                    (list.reverse (list.enumerate tuple)))))))
 
 (def: #export (path synthesize pattern bodyA)
-  (-> //.Synthesizer Pattern Analysis (Operation Path))
-  (path' pattern (:: //.Operation@Monad map (|>> #//.Then) (synthesize bodyA))))
+  (-> //.Synthesizer Pattern Analysis (Operation //.State Path))
+  (path' pattern (operation/map (|>> #//.Then) (synthesize bodyA))))
 
 (def: #export (weave leftP rightP)
   (-> Path Path Path)
@@ -124,8 +123,8 @@
       <default>)))
 
 (def: #export (synthesize synthesize^ inputA [headB tailB+])
-  (-> //.Synthesizer Analysis Match (Operation Synthesis))
-  (do //.Operation@Monad
+  (-> //.Synthesizer Analysis Match (Operation //.State Synthesis))
+  (do ///compiler.Monad<Operation>
     [inputS (synthesize^ inputA)]
     (case [headB tailB+]
       [[(#///analysis.Bind inputR) headB/bodyA]
@@ -139,7 +138,7 @@
         _
         (do @
           [arity //.scope-arity
-           headB/bodyS (//.with-new-local'
+           headB/bodyS (//.with-new-local
                          (synthesize^ headB/bodyA))]
           (wrap (//.branch/let [inputS
                                 (if (//function.nested? arity)
diff --git a/stdlib/source/lux/lang/synthesis/expression.lux b/stdlib/source/lux/lang/synthesis/expression.lux
index aab092777..2985d2d08 100644
--- a/stdlib/source/lux/lang/synthesis/expression.lux
+++ b/stdlib/source/lux/lang/synthesis/expression.lux
@@ -6,6 +6,7 @@
              (coll [list "list/" Functor<List>]
                    (dictionary ["dict" unordered #+ Dict]))))
   [///reference]
+  [///compiler "operation/" Monad<Operation>]
   [///analysis #+ Analysis]
   [///extension #+ Extension]
   [// #+ Synthesis]
@@ -35,8 +36,6 @@
      [#///analysis.Int #//.I64]
      [#///analysis.Deg #//.I64])))
 
-(open: "operation/" //.Operation@Monad)
-
 (def: #export (synthesizer extensions)
   (-> (Extension ///extension.Synthesis) //.Synthesizer)
   (function (synthesize analysis)
@@ -47,17 +46,17 @@
       (#///analysis.Structure composite)
       (case (///analysis.variant analysis)
         (#.Some variant)
-        (do //.Operation@Monad
+        (do ///compiler.Monad<Operation>
           [valueS (synthesize (get@ #///analysis.value variant))]
           (wrap (#//.Structure (#//.Variant (set@ #///analysis.value valueS variant)))))
 
         _
-        (do //.Operation@Monad
+        (do ///compiler.Monad<Operation>
           [tupleS (monad.map @ synthesize (///analysis.tuple analysis))]
           (wrap (#//.Structure (#//.Tuple tupleS)))))
 
       (#///analysis.Apply _)
-      (//function.apply (//.indirectly synthesize) analysis)
+      (//function.apply (|>> synthesize //.indirectly) analysis)
 
       (#///analysis.Function environmentA bodyA)
       (//function.function synthesize environmentA bodyA)
@@ -65,10 +64,10 @@
       (#///analysis.Special name args)
       (case (dict.get name extensions)
         #.None
-        (//.throw unknown-synthesis-extension name)
+        (///compiler.throw unknown-synthesis-extension name)
         
         (#.Some extension)
-        (extension (//.indirectly synthesize) args))
+        (extension (|>> synthesize //.indirectly) args))
 
       (#///analysis.Reference reference)
       (case reference
@@ -76,7 +75,7 @@
         (operation/wrap (#//.Reference reference))
 
         (#///reference.Variable var)
-        (do //.Operation@Monad
+        (do ///compiler.Monad<Operation>
           [resolver //.resolver]
           (case var
             (#///reference.Local register)
@@ -96,5 +95,5 @@
             (wrap (|> resolver (dict.get var) (maybe.default var) #///reference.Variable #//.Reference)))))
 
       (#///analysis.Case inputA branchesAB+)
-      (//case.synthesize (//.indirectly synthesize) inputA branchesAB+)
+      (//case.synthesize (|>> synthesize //.indirectly) inputA branchesAB+)
       )))
diff --git a/stdlib/source/lux/lang/synthesis/function.lux b/stdlib/source/lux/lang/synthesis/function.lux
index 8014c3b4a..cc40bea4d 100644
--- a/stdlib/source/lux/lang/synthesis/function.lux
+++ b/stdlib/source/lux/lang/synthesis/function.lux
@@ -9,12 +9,11 @@
              (coll [list "list/" Functor<List> Monoid<List> Fold<List>]
                    (dictionary ["dict" unordered #+ Dict]))))
   [///reference #+ Variable]
+  [///compiler #+ Operation]
   [///analysis #+ Environment Analysis]
   [// #+ Arity Synthesis Synthesizer]
   [//loop])
 
-(def: Operation@Monad (state.Monad<State'> error.Monad<Error>))
-
 (def: #export nested?
   (-> Arity Bool)
   (n/> +1))
@@ -72,16 +71,16 @@
   "")
 
 (def: return
-  (All [a] (-> (Maybe a) (//.Operation a)))
+  (All [a] (-> (Maybe a) (Operation //.State a)))
   (|>> (case> (#.Some output)
-              (:: Operation@Monad wrap output)
+              (:: ///compiler.Monad<Operation> wrap output)
 
               #.None
-              (//.throw cannot-prepare-function-body []))))
+              (///compiler.throw cannot-prepare-function-body []))))
 
 (def: #export (function synthesize environment body)
-  (-> Synthesizer Environment Analysis (//.Operation Synthesis))
-  (do Operation@Monad
+  (-> Synthesizer Environment Analysis (Operation //.State Synthesis))
+  (do ///compiler.Monad<Operation>
     [direct? //.direct?
      arity //.scope-arity
      resolver //.resolver
@@ -115,9 +114,9 @@
                        (list/fold (.function (_ var resolver')
                                     (dict.put var var resolver'))
                                   //.fresh-resolver
-                                  down-environment))
-           synthesize' (//.with-abstraction-state function-arity resolver' synthesize)]
-     bodyS (synthesize' body)]
+                                  down-environment))]
+     bodyS (//.with-abstraction function-arity resolver'
+             (synthesize body))]
     (case bodyS
       (^ (//.function/abstraction [env' down-arity' bodyS']))
       (let [arity' (inc down-arity')]