Moved extension machinery over.

7 files changed, 416 insertions, 19 deletions

diff --git a/stdlib/source/lux/tool/compiler/phase/extension.lux b/stdlib/source/lux/tool/compiler/phase/extension.lux
index fd54d54b4..86b2e6b38 100644
--- a/stdlib/source/lux/tool/compiler/phase/extension.lux
+++ b/stdlib/source/lux/tool/compiler/phase/extension.lux
@@ -58,6 +58,9 @@
              ["Expected" (%n arity)]
              ["Actual" (%n args)]))
 
+(exception: #export (incorrect-syntax {name Name})
+  (ex.report ["Extension" (%t name)]))
+
 (def: #export (install name handler)
   (All [s i o]
     (-> Text (Handler s i o) (Operation s i o Any)))
diff --git a/stdlib/source/lux/tool/compiler/phase/translation/js/extension.lux b/stdlib/source/lux/tool/compiler/phase/translation/js/extension.lux
new file mode 100644
index 000000000..a40b4953f
--- /dev/null
+++ b/stdlib/source/lux/tool/compiler/phase/translation/js/extension.lux
@@ -0,0 +1,15 @@
+(.module:
+  [lux #*
+   [data
+    [collection
+     ["." dictionary]]]]
+  [//
+   [runtime (#+ Bundle)]]
+  [/
+   ["." common]
+   ["." host]])
+
+(def: #export bundle
+  Bundle
+  (|> common.bundle
+      (dictionary.merge host.bundle)))
diff --git a/stdlib/source/lux/tool/compiler/phase/translation/js/extension/common.lux b/stdlib/source/lux/tool/compiler/phase/translation/js/extension/common.lux
new file mode 100644
index 000000000..3cf3fbc27
--- /dev/null
+++ b/stdlib/source/lux/tool/compiler/phase/translation/js/extension/common.lux
@@ -0,0 +1,231 @@
+(.module:
+  [lux #*
+   [control
+    ["." monad (#+ do)]
+    ["ex" exception (#+ exception:)]]
+   [data
+    ["e" error]
+    ["." product]
+    [number (#+ hex)]
+    [collection
+     ["." list ("#/." functor)]
+     ["." dictionary]]]
+   ["." macro (#+ with-gensyms)
+    ["." code]
+    ["s" syntax (#+ syntax:)]]
+   [host (#+ import:)
+    ["_" js (#+ Expression Computation)]]]
+  [///
+   ["///." runtime (#+ Operation Phase Handler Bundle)]
+   ["///." primitive]
+   ["//." ///
+    ["." synthesis (#+ Synthesis)]
+    ["." extension
+     ["." bundle]]]])
+
+(syntax: (Vector {size s.nat} elemT)
+  (wrap (list (` [(~+ (list.repeat size elemT))]))))
+
+(type: #export Nullary (-> (Vector 0 Expression) Computation))
+(type: #export Unary   (-> (Vector 1 Expression) Computation))
+(type: #export Binary  (-> (Vector 2 Expression) Computation))
+(type: #export Trinary (-> (Vector 3 Expression) Computation))
+(type: #export Variadic (-> (List Expression) Computation))
+
+(syntax: (arity: {name s.local-identifier} {arity s.nat})
+  (with-gensyms [g!_ g!extension g!name g!phase g!inputs]
+    (do @
+      [g!input+ (monad.seq @ (list.repeat arity (macro.gensym "input")))]
+      (wrap (list (` (def: #export ((~ (code.local-identifier name)) (~ g!extension))
+                       (-> (-> (..Vector (~ (code.nat arity)) Expression) Computation)
+                           Handler)
+                       (function ((~ g!_) (~ g!name) (~ g!phase) (~ g!inputs))
+                         (case (~ g!inputs)
+                           (^ (list (~+ g!input+)))
+                           (do /////.monad
+                             [(~+ (|> g!input+
+                                      (list/map (function (_ g!input)
+                                                  (list g!input (` ((~ g!phase) (~ g!input))))))
+                                      list.concat))]
+                             ((~' wrap) ((~ g!extension) [(~+ g!input+)])))
+
+                           (~' _)
+                           (/////.throw extension.incorrect-arity [(~ g!name) 1 (list.size (~ g!inputs))]))))))))))
+
+(arity: nullary 0)
+(arity: unary 1)
+(arity: binary 2)
+(arity: trinary 3)
+
+(def: #export (variadic extension)
+  (-> Variadic Handler)
+  (function (_ extension-name)
+    (function (_ phase inputsS)
+      (do /////.monad
+        [inputsI (monad.map @ phase inputsS)]
+        (wrap (extension inputsI))))))
+
+## [Procedures]
+## [[Bits]]
+(do-template [<name> <op>]
+  [(def: (<name> [subjectJS paramJS])
+     Binary
+     (<op> subjectJS (///runtime.i64//to-number paramJS)))]
+
+  [bit//left-shift             ///runtime.i64//left-shift]
+  [bit//arithmetic-right-shift ///runtime.i64//arithmetic-right-shift]
+  [bit//logical-right-shift    ///runtime.i64//logic-right-shift]
+  )
+
+## [[Numbers]]
+(import: #long java/lang/Double
+  (#static MIN_VALUE Double)
+  (#static MAX_VALUE Double))
+
+(do-template [<name> <const>]
+  [(def: (<name> _)
+     Nullary
+     (///primitive.f64 <const>))]
+
+  [frac//smallest (java/lang/Double::MIN_VALUE)]
+  [frac//min      (f/* -1.0 (java/lang/Double::MAX_VALUE))]
+  [frac//max      (java/lang/Double::MAX_VALUE)]
+  )
+
+(def: frac//decode
+  Unary
+  (|>> list
+       (_.apply/* (_.var "parseFloat"))
+       _.return
+       (_.closure (list))
+       ///runtime.lux//try))
+
+(def: int//char
+  Unary
+  (|>> ///runtime.i64//to-number
+       (list)
+       (_.apply/* (_.var "String.fromCharCode"))))
+
+## [[Text]]
+(def: (text//concat [subjectJS paramJS])
+  Binary
+  (|> subjectJS (_.do "concat" (list paramJS))))
+
+(do-template [<name> <runtime>]
+  [(def: (<name> [subjectJS paramJS extraJS])
+     Trinary
+     (<runtime> subjectJS paramJS extraJS))]
+
+  [text//clip  ///runtime.text//clip]
+  [text//index ///runtime.text//index]
+  )
+
+## [[IO]]
+(def: (io//log messageJS)
+  Unary
+  ($_ _.,
+      (///runtime.io//log messageJS)
+      ///runtime.unit))
+
+(def: (io//exit codeJS)
+  Unary
+  (let [@@process (_.var "process")
+        @@window (_.var "window")
+        @@location (_.var "location")]
+    ($_ _.or
+        ($_ _.and
+            (_.not (_.= _.undefined (_.type-of @@process)))
+            (_.the "exit" @@process)
+            (_.do "exit" (list (///runtime.i64//to-number codeJS)) @@process))
+        (_.do "close" (list) @@window)
+        (_.do "reload" (list) @@location))))
+
+(def: (io//current-time _)
+  Nullary
+  (|> (_.new (_.var "Date") (list))
+      (_.do "getTime" (list))
+      ///runtime.i64//from-number))
+
+## [Bundles]
+(def: lux-procs
+  Bundle
+  (|> bundle.empty
+      (bundle.install "is" (binary (product.uncurry _.=)))
+      (bundle.install "try" (unary ///runtime.lux//try))))
+
+(def: bit-procs
+  Bundle
+  (<| (bundle.prefix "bit")
+      (|> bundle.empty
+          (bundle.install "and" (binary (product.uncurry ///runtime.i64//and)))
+          (bundle.install "or" (binary (product.uncurry ///runtime.i64//or)))
+          (bundle.install "xor" (binary (product.uncurry ///runtime.i64//xor)))
+          (bundle.install "left-shift" (binary bit//left-shift))
+          (bundle.install "logical-right-shift" (binary bit//logical-right-shift))
+          (bundle.install "arithmetic-right-shift" (binary bit//arithmetic-right-shift))
+          )))
+
+(def: int-procs
+  Bundle
+  (<| (bundle.prefix "int")
+      (|> bundle.empty
+          (bundle.install "+" (binary (product.uncurry ///runtime.i64//+)))
+          (bundle.install "-" (binary (product.uncurry ///runtime.i64//-)))
+          (bundle.install "*" (binary (product.uncurry ///runtime.i64//*)))
+          (bundle.install "/" (binary (product.uncurry ///runtime.i64///)))
+          (bundle.install "%" (binary (product.uncurry ///runtime.i64//%)))
+          (bundle.install "=" (binary (product.uncurry ///runtime.i64//=)))
+          (bundle.install "<" (binary (product.uncurry ///runtime.i64//<)))
+          (bundle.install "to-frac" (unary ///runtime.i64//to-number))
+          (bundle.install "char" (unary int//char)))))
+
+(def: frac-procs
+  Bundle
+  (<| (bundle.prefix "frac")
+      (|> bundle.empty
+          (bundle.install "+" (binary (product.uncurry _.+)))
+          (bundle.install "-" (binary (product.uncurry _.-)))
+          (bundle.install "*" (binary (product.uncurry _.*)))
+          (bundle.install "/" (binary (product.uncurry _./)))
+          (bundle.install "%" (binary (product.uncurry _.%)))
+          (bundle.install "=" (binary (product.uncurry _.=)))
+          (bundle.install "<" (binary (product.uncurry _.<)))
+          (bundle.install "smallest" (nullary frac//smallest))
+          (bundle.install "min" (nullary frac//min))
+          (bundle.install "max" (nullary frac//max))
+          (bundle.install "to-int" (unary ///runtime.i64//from-number))
+          (bundle.install "encode" (unary (_.do "toString" (list))))
+          (bundle.install "decode" (unary frac//decode)))))
+
+(def: text-procs
+  Bundle
+  (<| (bundle.prefix "text")
+      (|> bundle.empty
+          (bundle.install "=" (binary (product.uncurry _.=)))
+          (bundle.install "<" (binary (product.uncurry _.<)))
+          (bundle.install "concat" (binary text//concat))
+          (bundle.install "index" (trinary text//index))
+          (bundle.install "size" (unary (_.the "length")))
+          (bundle.install "char" (binary (product.uncurry ///runtime.text//char)))
+          (bundle.install "clip" (trinary text//clip))
+          )))
+
+(def: io-procs
+  Bundle
+  (<| (bundle.prefix "io")
+      (|> bundle.empty
+          (bundle.install "log" (unary io//log))
+          (bundle.install "error" (unary ///runtime.io//error))
+          (bundle.install "exit" (unary io//exit))
+          (bundle.install "current-time" (nullary io//current-time)))))
+
+(def: #export bundle
+  Bundle
+  (<| (bundle.prefix "lux")
+      (|> lux-procs
+          (dictionary.merge bit-procs)
+          (dictionary.merge int-procs)
+          (dictionary.merge frac-procs)
+          (dictionary.merge text-procs)
+          (dictionary.merge io-procs)
+          )))
diff --git a/stdlib/source/lux/tool/compiler/phase/translation/js/extension/host.lux b/stdlib/source/lux/tool/compiler/phase/translation/js/extension/host.lux
new file mode 100644
index 000000000..637cadc5f
--- /dev/null
+++ b/stdlib/source/lux/tool/compiler/phase/translation/js/extension/host.lux
@@ -0,0 +1,120 @@
+(.module:
+  [lux #*
+   [control
+    ["." monad (#+ do)]]
+   [data
+    ["." product]
+    [collection
+     ["." dictionary]]]
+   [host
+    ["_" js]]]
+  [//
+   ["." common (#+ Nullary Binary Trinary Variadic)]
+   [//
+    ["///." runtime (#+ Handler Bundle)]
+    ["//." ///
+     ["." synthesis]
+     ["." extension
+      ["." bundle]]]]])
+
+(do-template [<name> <js>]
+  [(def: (<name> _) Nullary <js>)]
+
+  [js//null      _.null]
+  [js//undefined _.undefined]
+  [js//object    (_.object (list))]
+  )
+
+(def: (js//global name translate inputs)
+  Handler
+  (case inputs
+    (^ (list (synthesis.text global)))
+    (:: /////.monad wrap (_.var global))
+
+    _
+    (/////.throw extension.incorrect-syntax name)))
+
+(def: (js//call name translate inputs)
+  Handler
+  (case inputs
+    (^ (list& functionS argsS+))
+    (do /////.monad
+      [functionJS (translate functionS)
+       argsJS+ (monad.map @ translate argsS+)]
+      (wrap (_.apply/* functionJS argsJS+)))
+
+    _
+    (/////.throw extension.incorrect-syntax name)))
+
+(def: js
+  Bundle
+  (|> bundle.empty
+      (bundle.install "null" (common.nullary js//null))
+      (bundle.install "undefined" (common.nullary js//undefined))
+      (bundle.install "object" (common.nullary js//object))
+      (bundle.install "array" (common.variadic _.array))
+      (bundle.install "global" js//global)
+      (bundle.install "call" js//call)))
+
+(def: (object//new name translate inputs)
+  Handler
+  (case inputs
+    (^ (list& constructorS argsS+))
+    (do /////.monad
+      [constructorJS (translate constructorS)
+       argsJS+ (monad.map @ translate argsS+)]
+      (wrap (_.new constructorJS argsJS+)))
+
+    _
+    (/////.throw extension.incorrect-syntax name)))
+
+(def: (object//call name translate inputs)
+  Handler
+  (case inputs
+    (^ (list& objectS methodS argsS+))
+    (do /////.monad
+      [objectJS (translate objectS)
+       methodJS (translate methodS)
+       argsJS+ (monad.map @ translate argsS+)]
+      (wrap (|> objectJS
+                (_.at methodJS)
+                (_.do "apply" (list& objectJS argsJS+)))))
+
+    _
+    (/////.throw extension.incorrect-syntax name)))
+
+(def: (object//set [fieldJS valueJS objectJS])
+  Trinary
+  (///runtime.js//set objectJS fieldJS valueJS))
+
+(def: object
+  Bundle
+  (<| (bundle.prefix "object")
+      (|> bundle.empty
+          (bundle.install "new" object//new)
+          (bundle.install "call" object//call)
+          (bundle.install "read" (common.binary (product.uncurry ///runtime.js//get)))
+          (bundle.install "write" (common.trinary object//set))
+          (bundle.install "delete" (common.binary (product.uncurry ///runtime.js//delete)))
+          )))
+
+(def: (array//write [indexJS valueJS arrayJS])
+  Trinary
+  (///runtime.array//write indexJS valueJS arrayJS))
+
+(def: array
+  Bundle
+  (<| (bundle.prefix "array")
+      (|> bundle.empty
+          (bundle.install "read" (common.binary (product.uncurry ///runtime.array//read)))
+          (bundle.install "write" (common.trinary array//write))
+          (bundle.install "delete" (common.binary (product.uncurry ///runtime.array//delete)))
+          (bundle.install "length" (common.unary (_.the "length")))
+          )))
+
+(def: #export bundle
+  Bundle
+  (<| (bundle.prefix "js")
+      (|> ..js
+          (dictionary.merge ..object)
+          (dictionary.merge ..array))))
diff --git a/stdlib/source/lux/tool/compiler/phase/translation/js/primitive.lux b/stdlib/source/lux/tool/compiler/phase/translation/js/primitive.lux
index f2bee19c5..ff72b1ac6 100644
--- a/stdlib/source/lux/tool/compiler/phase/translation/js/primitive.lux
+++ b/stdlib/source/lux/tool/compiler/phase/translation/js/primitive.lux
@@ -7,12 +7,12 @@
      ["." i64]
      ["." frac]]]
    [host
-    ["_" js (#+ Expression)]]]
+    ["_" js (#+ Computation)]]]
   [//
    ["//." runtime]])
 
 (def: #export bit
-  (-> Bit Expression)
+  (-> Bit Computation)
   _.boolean)
 
 (def: high
@@ -25,12 +25,12 @@
     (|>> (i64.and mask))))
 
 (def: #export (i64 value)
-  (-> (I64 Any) Expression)
+  (-> (I64 Any) Computation)
   (//runtime.i64//new (|> value ..high .int _.i32)
                       (|> value ..low .int _.i32)))
 
 (def: #export f64
-  (-> Frac Expression)
+  (-> Frac Computation)
   (|>> (cond> [(f/= frac.positive-infinity)]
               [(new> _.positive-infinity [])]
               
@@ -44,5 +44,5 @@
               [_.number])))
 
 (def: #export text
-  (-> Text Expression)
+  (-> Text Computation)
   _.string)
diff --git a/stdlib/source/lux/tool/compiler/phase/translation/js/runtime.lux b/stdlib/source/lux/tool/compiler/phase/translation/js/runtime.lux
index c8e86dcb5..a7b8a5a05 100644
--- a/stdlib/source/lux/tool/compiler/phase/translation/js/runtime.lux
+++ b/stdlib/source/lux/tool/compiler/phase/translation/js/runtime.lux
@@ -149,8 +149,7 @@
 
 (runtime: (lux//program-args)
   (with-vars [process output idx]
-    (_.if (_.and (_.not (_.= (_.type-of process)
-                             _.undefined))
+    (_.if (_.and (|> process _.type-of (_.= _.undefined) _.not)
                  (|> process (_.the "argv")))
       ($_ _.then
           (_.define output ..none)
@@ -671,9 +670,11 @@
 
 (runtime: (js//get object field)
   (with-vars [temp]
-    (_.if (|> temp (_.= _.undefined) _.not)
-      (_.return (..some temp))
-      (_.return ..none))))
+    ($_ _.then
+        (_.define temp (_.at field object))
+        (_.if (_.= _.undefined temp)
+          (_.return ..none)
+          (_.return (..some temp))))))
 
 (runtime: (js//set object field input)
   ($_ _.then
@@ -685,18 +686,46 @@
       (_.delete (_.at field object))
       (_.return object)))
 
-(runtime: (js//call object method inputs)
-  (_.return (_.apply/2 (_.at method object) object inputs)))
-
 (def: runtime//js
   Statement
   ($_ _.then
       @js//get
       @js//set
       @js//delete
-      @js//call
       ))
 
+(runtime: (array//read idx array)
+  (let [fail! (_.return ..none)]
+    (_.if (_.< (_.the "length" array) idx)
+      (with-vars [temp]
+        ($_ _.then
+            (_.define temp (_.at idx array))
+            (_.if (_.= _.undefined temp)
+              fail!
+              (_.return (..some temp)))))
+      fail!)))
+
+(runtime: (array//write idx value array)
+  (_.if (_.< (_.the "length" array) idx)
+    ($_ _.then
+        (_.set (_.at idx array) value)
+        (_.return (..some array)))
+    (_.return ..none)))
+
+(runtime: (array//delete idx array)
+  (_.if (_.< (_.the "length" array) idx)
+    ($_ _.then
+        (_.delete (_.at idx array))
+        (_.return (..some array)))
+    (_.return ..none)))
+
+(def: runtime//array
+  Statement
+  ($_ _.then
+      @array//read
+      @array//write
+      @array//delete))
+
 (def: runtime
   Statement
   ($_ _.then
@@ -706,6 +735,7 @@
       runtime//text
       runtime//io
       runtime//js
+      runtime//array
       ))
 
 (def: #export artifact Text (format prefix ".js"))
diff --git a/stdlib/source/lux/tool/compiler/phase/translation/scheme/extension/common.jvm.lux b/stdlib/source/lux/tool/compiler/phase/translation/scheme/extension/common.jvm.lux
index 1c55abf83..d430aba24 100644
--- a/stdlib/source/lux/tool/compiler/phase/translation/scheme/extension/common.jvm.lux
+++ b/stdlib/source/lux/tool/compiler/phase/translation/scheme/extension/common.jvm.lux
@@ -15,16 +15,14 @@
    ["." macro (#+ with-gensyms)
     ["." code]
     ["s" syntax (#+ syntax:)]]
-   [host (#+ import:)]]
+   [host (#+ import:)
+    ["_" scheme (#+ Expression Computation)]]]
   [///
    ["." runtime (#+ Operation Phase Handler Bundle)]
    ["//." ///
     ["." synthesis (#+ Synthesis)]
     ["." extension
-     ["." bundle]]
-    [///
-     [host
-      ["_" scheme (#+ Expression Computation)]]]]])
+     ["." bundle]]]])
 
 (syntax: (Vector {size s.nat} elemT)
   (wrap (list (` [(~+ (list.repeat size elemT))]))))