1 files changed, 250 insertions, 0 deletions
diff --git a/stdlib/source/lux/platform/compiler/default/phase/translation.lux b/stdlib/source/lux/platform/compiler/default/phase/translation.lux
new file mode 100644
index 000000000..fb40f4652
--- /dev/null
+++ b/stdlib/source/lux/platform/compiler/default/phase/translation.lux
@@ -0,0 +1,250 @@
+(.module:
+  [lux #*
+   [control
+    ["ex" exception (#+ exception:)]
+    [monad (#+ do)]]
+   [data
+    ["." product]
+    ["." error (#+ Error)]
+    ["." name ("name/." Equivalence<Name>)]
+    ["." text
+     format]
+    [collection
+     ["." row (#+ Row)]
+     ["." dictionary (#+ Dictionary)]]]
+   [world
+    [file (#+ File)]]]
+  ["." //
+   ["." extension]]
+  [//synthesis (#+ Synthesis)])
+
+(do-template [<name>]
+  [(exception: #export (<name>)
+     "")]
+
+  [no-active-buffer]
+  [no-anchor]
+  )
+
+(exception: #export (cannot-interpret {error Text})
+  (ex.report ["Error" error]))
+
+(exception: #export (unknown-lux-name {name Name})
+  (ex.report ["Name" (%name name)]))
+
+(exception: #export (cannot-overwrite-lux-name {lux-name Name}
+                                               {old-host-name Text}
+                                               {new-host-name Text})
+  (ex.report ["Lux Name" (%name lux-name)]
+             ["Old Host Name" old-host-name]
+             ["New Host Name" new-host-name]))
+
+(do-template [<name>]
+  [(exception: #export (<name> {name Name})
+     (ex.report ["Output" (%name name)]))]
+
+  [cannot-overwrite-output]
+  [no-buffer-for-saving-code]
+  )
+
+(type: #export Context
+  {#scope-name Text
+   #inner-functions Nat})
+
+(signature: #export (Host expression statement)
+  (: (-> Text expression (Error Any))
+     evaluate!)
+  (: (-> Text statement (Error Any))
+     execute!)
+  (: (-> Name expression (Error [Text Any]))
+     define!))
+
+(type: #export (Buffer statement) (Row [Name statement]))
+
+(type: #export (Outputs statement) (Dictionary File (Buffer statement)))
+
+(type: #export (State anchor expression statement)
+  {#context Context
+   #anchor (Maybe anchor)
+   #host (Host expression statement)
+   #buffer (Maybe (Buffer statement))
+   #outputs (Outputs statement)
+   #counter Nat
+   #name-cache (Dictionary Name Text)})
+
+(do-template [<special> <general>]
+  [(type: #export (<special> anchor expression statement)
+     (<general> (State anchor expression statement) Synthesis expression))]
+
+  [State+    extension.State]
+  [Operation extension.Operation]
+  [Phase     extension.Phase]
+  [Handler   extension.Handler]
+  [Bundle    extension.Bundle]
+  )
+
+(def: #export (state host)
+  (All [anchor expression statement]
+    (-> (Host expression statement)
+        (..State anchor expression statement)))
+  {#context {#scope-name ""
+             #inner-functions 0}
+   #anchor #.None
+   #host host
+   #buffer #.None
+   #outputs (dictionary.new text.Hash<Text>)
+   #counter 0
+   #name-cache (dictionary.new name.Hash<Name>)})
+
+(def: #export (with-context expr)
+  (All [anchor expression statement output]
+    (-> (Operation anchor expression statement output)
+        (Operation anchor expression statement [Text output])))
+  (function (_ [bundle state])
+    (let [[old-scope old-inner] (get@ #context state)
+          new-scope (format old-scope "c" (%n old-inner))]
+      (case (expr [bundle (set@ #context [new-scope 0] state)])
+        (#error.Success [[bundle' state'] output])
+        (#error.Success [[bundle' (set@ #context [old-scope (inc old-inner)] state')]
+                         [new-scope output]])
+
+        (#error.Error error)
+        (#error.Error error)))))
+
+(def: #export context
+  (All [anchor expression statement]
+    (Operation anchor expression statement Text))
+  (extension.read (|>> (get@ #context)
+                       (get@ #scope-name))))
+
+(do-template [<tag>
+              <with-declaration> <with-type> <with-value>
+              <get> <get-type> <exception>]
+  [(def: #export <with-declaration>
+     (All [anchor expression statement output] <with-type>)
+     (function (_ body)
+       (function (_ [bundle state])
+         (case (body [bundle (set@ <tag> (#.Some <with-value>) state)])
+           (#error.Success [[bundle' state'] output])
+           (#error.Success [[bundle' (set@ <tag> (get@ <tag> state) state')]
+                            output])
+
+           (#error.Error error)
+           (#error.Error error)))))
+
+   (def: #export <get>
+     (All [anchor expression statement]
+       (Operation anchor expression statement <get-type>))
+     (function (_ (^@ stateE [bundle state]))
+       (case (get@ <tag> state)
+         (#.Some output)
+         (#error.Success [stateE output])
+
+         #.None
+         (ex.throw <exception> []))))]
+
+  [#anchor
+   (with-anchor anchor)
+   (-> anchor (Operation anchor expression statement output)
+       (Operation anchor expression statement output))
+   anchor
+   anchor anchor no-anchor]
+
+  [#buffer
+   with-buffer
+   (-> (Operation anchor expression statement output)
+       (Operation anchor expression statement output))
+   row.empty
+   buffer (Buffer statement) no-active-buffer]
+  )
+
+(def: #export outputs
+  (All [anchor expression statement]
+    (Operation anchor expression statement (Outputs statement)))
+  (extension.read (get@ #outputs)))
+
+(def: #export next
+  (All [anchor expression statement]
+    (Operation anchor expression statement Nat))
+  (do //.Monad<Operation>
+    [count (extension.read (get@ #counter))
+     _ (extension.update (update@ #counter inc))]
+    (wrap count)))
+
+(do-template [<name> <inputT>]
+  [(def: #export (<name> label code)
+     (All [anchor expression statement]
+       (-> Text <inputT> (Operation anchor expression statement Any)))
+     (function (_ (^@ state+ [bundle state]))
+       (case (:: (get@ #host state) <name> label code)
+         (#error.Success output)
+         (#error.Success [state+ output])
+
+         (#error.Error error)
+         (ex.throw cannot-interpret error))))]
+
+  [evaluate! expression]
+  [execute!  statement]
+  )
+
+(def: #export (define! name code)
+  (All [anchor expression statement]
+    (-> Name expression (Operation anchor expression statement [Text Any])))
+  (function (_ (^@ stateE [bundle state]))
+    (case (:: (get@ #host state) define! name code)
+      (#error.Success output)
+      (#error.Success [stateE output])
+
+      (#error.Error error)
+      (ex.throw cannot-interpret error))))
+
+(def: #export (save! name code)
+  (All [anchor expression statement]
+    (-> Name statement (Operation anchor expression statement Any)))
+  (do //.Monad<Operation>
+    [count ..next
+     _ (execute! (format "save" (%n count)) code)
+     ?buffer (extension.read (get@ #buffer))]
+    (case ?buffer
+      (#.Some buffer)
+      (if (row.any? (|>> product.left (name/= name)) buffer)
+        (//.throw cannot-overwrite-output name)
+        (extension.update (set@ #buffer (#.Some (row.add [name code] buffer)))))
+      
+      #.None
+      (//.throw no-buffer-for-saving-code name))))
+
+(def: #export (save-buffer! target)
+  (All [anchor expression statement]
+    (-> File (Operation anchor expression statement Any)))
+  (do //.Monad<Operation>
+    [buffer ..buffer]
+    (extension.update (update@ #outputs (dictionary.put target buffer)))))
+
+(def: #export (remember lux-name)
+  (All [anchor expression statement]
+    (-> Name (Operation anchor expression statement Text)))
+  (function (_ (^@ stateE [_ state]))
+    (let [cache (get@ #name-cache state)]
+      (case (dictionary.get lux-name cache)
+        (#.Some host-name)
+        (#error.Success [stateE host-name])
+        
+        #.None
+        (ex.throw unknown-lux-name lux-name)))))
+
+(def: #export (learn lux-name host-name)
+  (All [anchor expression statement]
+    (-> Name Text (Operation anchor expression statement Any)))
+  (function (_ [bundle state])
+    (let [cache (get@ #name-cache state)]
+      (case (dictionary.get lux-name cache)
+        #.None
+        (#error.Success [[bundle
+                          (update@ #name-cache
+                                   (dictionary.put lux-name host-name)
+                                   state)]
+                         []])
+
+        (#.Some old-host-name)
+        (ex.throw cannot-overwrite-lux-name [lux-name old-host-name host-name])))))