1 files changed, 370 insertions, 0 deletions
diff --git a/stdlib/source/lux/compiler/default/phase/extension/analysis/common.lux b/stdlib/source/lux/compiler/default/phase/extension/analysis/common.lux
new file mode 100644
index 000000000..2817fd55d
--- /dev/null
+++ b/stdlib/source/lux/compiler/default/phase/extension/analysis/common.lux
@@ -0,0 +1,370 @@
+(.module:
+  [lux #*
+   [control
+    ["." monad (#+ do)]
+    ["ex" exception (#+ exception:)]
+    [thread (#+ Box)]]
+   [concurrency
+    [atom (#+ Atom)]]
+   [data
+    ["." text
+     format]
+    [collection
+     ["." list ("list/." Functor<List>)]
+     ["." array]
+     ["dict" dictionary (#+ Dictionary)]]]
+   [type
+    ["." check]]
+   [io (#+ IO)]]
+  ["." ////
+   ["." analysis (#+ Analysis Handler Bundle)
+    [".A" type]
+    [".A" case]
+    [".A" function]]]
+  ["." ///
+   ["." bundle]])
+
+## [Utils]
+(def: (simple inputsT+ outputT)
+  (-> (List Type) Type Handler)
+  (let [num-expected (list.size inputsT+)]
+    (function (_ extension-name analyse args)
+      (let [num-actual (list.size args)]
+        (if (n/= num-expected num-actual)
+          (do ////.Monad<Operation>
+            [_ (typeA.infer outputT)
+             argsA (monad.map @
+                              (function (_ [argT argC])
+                                (typeA.with-type argT
+                                  (analyse argC)))
+                              (list.zip2 inputsT+ args))]
+            (wrap (#analysis.Extension extension-name argsA)))
+          (////.throw bundle.incorrect-arity [extension-name num-expected num-actual]))))))
+
+(def: #export (nullary valueT)
+  (-> Type Handler)
+  (simple (list) valueT))
+
+(def: #export (unary inputT outputT)
+  (-> Type Type Handler)
+  (simple (list inputT) outputT))
+
+(def: #export (binary subjectT paramT outputT)
+  (-> Type Type Type Handler)
+  (simple (list subjectT paramT) outputT))
+
+(def: #export (trinary subjectT param0T param1T outputT)
+  (-> Type Type Type Type Handler)
+  (simple (list subjectT param0T param1T) outputT))
+
+## [Analysers]
+## "lux is" represents reference/pointer equality.
+(def: lux::is
+  Handler
+  (function (_ extension-name analyse args)
+    (do ////.Monad<Operation>
+      [[var-id varT] (typeA.with-env check.var)]
+      ((binary varT varT Bit extension-name)
+       analyse args))))
+
+## "lux try" provides a simple way to interact with the host platform's
+## error-handling facilities.
+(def: lux::try
+  Handler
+  (function (_ extension-name analyse args)
+    (case args
+      (^ (list opC))
+      (do ////.Monad<Operation>
+        [[var-id varT] (typeA.with-env check.var)
+         _ (typeA.infer (type (Either Text varT)))
+         opA (typeA.with-type (type (IO varT))
+               (analyse opC))]
+        (wrap (#analysis.Extension extension-name (list opA))))
+      
+      _
+      (////.throw bundle.incorrect-arity [extension-name +1 (list.size args)]))))
+
+(def: lux::in-module
+  Handler
+  (function (_ extension-name analyse argsC+)
+    (case argsC+
+      (^ (list [_ (#.Text module-name)] exprC))
+      (analysis.with-current-module module-name
+        (analyse exprC))
+      
+      _
+      (////.throw bundle.invalid-syntax [extension-name]))))
+
+## (do-template [<name> <type>]
+##   [(def: <name>
+##      Handler
+##      (function (_ extension-name analyse args)
+##        (case args
+##          (^ (list typeC valueC))
+##          (do ////.Monad<Operation>
+##            [actualT (eval Type typeC)
+##             _ (typeA.infer (:coerce Type actualT))]
+##            (typeA.with-type <type>
+##              (analyse valueC)))
+
+##          _
+##          (////.throw bundle.incorrect-arity [extension-name +2 (list.size args)]))))]
+
+##   [lux::check  (:coerce Type actualT)]
+##   [lux::coerce Any]
+##   )
+
+(def: lux::check::type
+  Handler
+  (function (_ extension-name analyse args)
+    (case args
+      (^ (list valueC))
+      (do ////.Monad<Operation>
+        [_ (typeA.infer Type)
+         valueA (typeA.with-type Type
+                  (analyse valueC))]
+        (wrap valueA))
+      
+      _
+      (////.throw bundle.incorrect-arity [extension-name +1 (list.size args)]))))
+
+(def: bundle::lux
+  Bundle
+  (|> bundle.empty
+      (bundle.install "is" lux::is)
+      (bundle.install "try" lux::try)
+      ## (bundle.install "check" lux::check)
+      ## (bundle.install "coerce" lux::coerce)
+      (bundle.install "check type" lux::check::type)
+      (bundle.install "in-module" lux::in-module)))
+
+(def: bundle::io
+  Bundle
+  (<| (bundle.prefix "io")
+      (|> bundle.empty
+          (bundle.install "log" (unary Text Any))
+          (bundle.install "error" (unary Text Nothing))
+          (bundle.install "exit" (unary Int Nothing))
+          (bundle.install "current-time" (nullary Int)))))
+
+(def: bundle::bit
+  Bundle
+  (<| (bundle.prefix "bit")
+      (|> bundle.empty
+          (bundle.install "and" (binary Nat Nat Nat))
+          (bundle.install "or" (binary Nat Nat Nat))
+          (bundle.install "xor" (binary Nat Nat Nat))
+          (bundle.install "left-shift" (binary Nat Nat Nat))
+          (bundle.install "logical-right-shift" (binary Nat Nat Nat))
+          (bundle.install "arithmetic-right-shift" (binary Int Nat Int))
+          )))
+
+(def: bundle::int
+  Bundle
+  (<| (bundle.prefix "int")
+      (|> bundle.empty
+          (bundle.install "+" (binary Int Int Int))
+          (bundle.install "-" (binary Int Int Int))
+          (bundle.install "*" (binary Int Int Int))
+          (bundle.install "/" (binary Int Int Int))
+          (bundle.install "%" (binary Int Int Int))
+          (bundle.install "=" (binary Int Int Bit))
+          (bundle.install "<" (binary Int Int Bit))
+          (bundle.install "to-frac" (unary Int Frac))
+          (bundle.install "char" (unary Int Text)))))
+
+(def: bundle::frac
+  Bundle
+  (<| (bundle.prefix "frac")
+      (|> bundle.empty
+          (bundle.install "+" (binary Frac Frac Frac))
+          (bundle.install "-" (binary Frac Frac Frac))
+          (bundle.install "*" (binary Frac Frac Frac))
+          (bundle.install "/" (binary Frac Frac Frac))
+          (bundle.install "%" (binary Frac Frac Frac))
+          (bundle.install "=" (binary Frac Frac Bit))
+          (bundle.install "<" (binary Frac Frac Bit))
+          (bundle.install "smallest" (nullary Frac))
+          (bundle.install "min" (nullary Frac))
+          (bundle.install "max" (nullary Frac))
+          (bundle.install "to-rev" (unary Frac Rev))
+          (bundle.install "to-int" (unary Frac Int))
+          (bundle.install "encode" (unary Frac Text))
+          (bundle.install "decode" (unary Text (type (Maybe Frac)))))))
+
+(def: bundle::text
+  Bundle
+  (<| (bundle.prefix "text")
+      (|> bundle.empty
+          (bundle.install "=" (binary Text Text Bit))
+          (bundle.install "<" (binary Text Text Bit))
+          (bundle.install "concat" (binary Text Text Text))
+          (bundle.install "index" (trinary Text Text Nat (type (Maybe Nat))))
+          (bundle.install "size" (unary Text Nat))
+          (bundle.install "char" (binary Text Nat (type (Maybe Nat))))
+          (bundle.install "clip" (trinary Text Nat Nat (type (Maybe Text))))
+          )))
+
+(def: array::get
+  Handler
+  (function (_ extension-name analyse args)
+    (do ////.Monad<Operation>
+      [[var-id varT] (typeA.with-env check.var)]
+      ((binary (type (Array varT)) Nat (type (Maybe varT)) extension-name)
+       analyse args))))
+
+(def: array::put
+  Handler
+  (function (_ extension-name analyse args)
+    (do ////.Monad<Operation>
+      [[var-id varT] (typeA.with-env check.var)]
+      ((trinary (type (Array varT)) Nat varT (type (Array varT)) extension-name)
+       analyse args))))
+
+(def: array::remove
+  Handler
+  (function (_ extension-name analyse args)
+    (do ////.Monad<Operation>
+      [[var-id varT] (typeA.with-env check.var)]
+      ((binary (type (Array varT)) Nat (type (Array varT)) extension-name)
+       analyse args))))
+
+(def: bundle::array
+  Bundle
+  (<| (bundle.prefix "array")
+      (|> bundle.empty
+          (bundle.install "new" (unary Nat Array))
+          (bundle.install "get" array::get)
+          (bundle.install "put" array::put)
+          (bundle.install "remove" array::remove)
+          (bundle.install "size" (unary (type (Ex [a] (Array a))) Nat))
+          )))
+
+(def: bundle::math
+  Bundle
+  (<| (bundle.prefix "math")
+      (|> bundle.empty
+          (bundle.install "cos" (unary Frac Frac))
+          (bundle.install "sin" (unary Frac Frac))
+          (bundle.install "tan" (unary Frac Frac))
+          (bundle.install "acos" (unary Frac Frac))
+          (bundle.install "asin" (unary Frac Frac))
+          (bundle.install "atan" (unary Frac Frac))
+          (bundle.install "cosh" (unary Frac Frac))
+          (bundle.install "sinh" (unary Frac Frac))
+          (bundle.install "tanh" (unary Frac Frac))
+          (bundle.install "exp" (unary Frac Frac))
+          (bundle.install "log" (unary Frac Frac))
+          (bundle.install "ceil" (unary Frac Frac))
+          (bundle.install "floor" (unary Frac Frac))
+          (bundle.install "round" (unary Frac Frac))
+          (bundle.install "atan2" (binary Frac Frac Frac))
+          (bundle.install "pow" (binary Frac Frac Frac))
+          )))
+
+(def: atom::new
+  Handler
+  (function (_ extension-name analyse args)
+    (case args
+      (^ (list initC))
+      (do ////.Monad<Operation>
+        [[var-id varT] (typeA.with-env check.var)
+         _ (typeA.infer (type (Atom varT)))
+         initA (typeA.with-type varT
+                 (analyse initC))]
+        (wrap (#analysis.Extension extension-name (list initA))))
+      
+      _
+      (////.throw bundle.incorrect-arity [extension-name +1 (list.size args)]))))
+
+(def: atom::read
+  Handler
+  (function (_ extension-name analyse args)
+    (do ////.Monad<Operation>
+      [[var-id varT] (typeA.with-env check.var)]
+      ((unary (type (Atom varT)) varT extension-name)
+       analyse args))))
+
+(def: atom::compare-and-swap
+  Handler
+  (function (_ extension-name analyse args)
+    (do ////.Monad<Operation>
+      [[var-id varT] (typeA.with-env check.var)]
+      ((trinary (type (Atom varT)) varT varT Bit extension-name)
+       analyse args))))
+
+(def: bundle::atom
+  Bundle
+  (<| (bundle.prefix "atom")
+      (|> bundle.empty
+          (bundle.install "new" atom::new)
+          (bundle.install "read" atom::read)
+          (bundle.install "compare-and-swap" atom::compare-and-swap)
+          )))
+
+(def: box::new
+  Handler
+  (function (_ extension-name analyse args)
+    (case args
+      (^ (list initC))
+      (do ////.Monad<Operation>
+        [[var-id varT] (typeA.with-env check.var)
+         _ (typeA.infer (type (All [!] (Box ! varT))))
+         initA (typeA.with-type varT
+                 (analyse initC))]
+        (wrap (#analysis.Extension extension-name (list initA))))
+      
+      _
+      (////.throw bundle.incorrect-arity [extension-name +1 (list.size args)]))))
+
+(def: box::read
+  Handler
+  (function (_ extension-name analyse args)
+    (do ////.Monad<Operation>
+      [[thread-id threadT] (typeA.with-env check.var)
+       [var-id varT] (typeA.with-env check.var)]
+      ((unary (type (Box threadT varT)) varT extension-name)
+       analyse args))))
+
+(def: box::write
+  Handler
+  (function (_ extension-name analyse args)
+    (do ////.Monad<Operation>
+      [[thread-id threadT] (typeA.with-env check.var)
+       [var-id varT] (typeA.with-env check.var)]
+      ((binary varT (type (Box threadT varT)) Any extension-name)
+       analyse args))))
+
+(def: bundle::box
+  Bundle
+  (<| (bundle.prefix "box")
+      (|> bundle.empty
+          (bundle.install "new" box::new)
+          (bundle.install "read" box::read)
+          (bundle.install "write" box::write)
+          )))
+
+(def: bundle::process
+  Bundle
+  (<| (bundle.prefix "process")
+      (|> bundle.empty
+          (bundle.install "parallelism" (nullary Nat))
+          (bundle.install "schedule" (binary Nat (type (IO Any)) Any))
+          )))
+
+(def: #export bundle
+  Bundle
+  (<| (bundle.prefix "lux")
+      (|> bundle.empty
+          (dict.merge bundle::lux)
+          (dict.merge bundle::bit)
+          (dict.merge bundle::int)
+          (dict.merge bundle::frac)
+          (dict.merge bundle::text)
+          (dict.merge bundle::array)
+          (dict.merge bundle::math)
+          (dict.merge bundle::atom)
+          (dict.merge bundle::box)
+          (dict.merge bundle::process)
+          (dict.merge bundle::io))
+      ))