- All analysis procedures have been turned into extensions.

1 files changed, 419 insertions, 0 deletions

diff --git a/new-luxc/source/luxc/lang/extension/analysis/common.lux b/new-luxc/source/luxc/lang/extension/analysis/common.lux
new file mode 100644
index 000000000..079001b26
--- /dev/null
+++ b/new-luxc/source/luxc/lang/extension/analysis/common.lux
@@ -0,0 +1,419 @@
+(.module:
+  lux
+  (lux (control [monad #+ do]
+                ["ex" exception #+ exception:])
+       (concurrency [atom #+ Atom])
+       (data [text]
+             text/format
+             (coll [list "list/" Functor<List>]
+                   [array]
+                   [dict #+ Dict]))
+       [macro]
+       (macro [code])
+       (lang (type ["tc" check]))
+       [io])
+  (luxc ["&" lang]
+        (lang ["la" analysis]
+              (analysis ["&." common]
+                        [".A" function]
+                        [".A" case]
+                        [".A" type])))
+  [///])
+
+(exception: #export Incorrect-Procedure-Arity)
+(exception: #export Invalid-Syntax)
+
+## [Utils]
+(type: #export Bundle
+  (Dict Text (-> Text ///.Analysis)))
+
+(def: #export (install name unnamed)
+  (-> Text (-> Text ///.Analysis)
+      (-> Bundle Bundle))
+  (dict.put name unnamed))
+
+(def: #export (prefix prefix bundle)
+  (-> Text Bundle Bundle)
+  (|> bundle
+      dict.entries
+      (list/map (function [[key val]] [(format prefix " " key) val]))
+      (dict.from-list text.Hash<Text>)))
+
+(def: #export (wrong-arity proc expected actual)
+  (-> Text Nat Nat Text)
+  (format "      Procedure: " (%t proc) "\n"
+          " Expected Arity: " (|> expected nat-to-int %i) "\n"
+          "   Actual Arity: " (|> actual nat-to-int %i)))
+
+(def: (simple proc inputsT+ outputT)
+  (-> Text (List Type) Type ///.Analysis)
+  (let [num-expected (list.size inputsT+)]
+    (function [analyse eval args]
+      (let [num-actual (list.size args)]
+        (if (n/= num-expected num-actual)
+          (do macro.Monad<Meta>
+            [_ (&.infer outputT)
+             argsA (monad.map @
+                              (function [[argT argC]]
+                                (&.with-type argT
+                                  (analyse argC)))
+                              (list.zip2 inputsT+ args))]
+            (wrap (la.procedure proc argsA)))
+          (&.throw Incorrect-Procedure-Arity (wrong-arity proc num-expected num-actual)))))))
+
+(def: #export (nullary valueT proc)
+  (-> Type Text ///.Analysis)
+  (simple proc (list) valueT))
+
+(def: #export (unary inputT outputT proc)
+  (-> Type Type Text ///.Analysis)
+  (simple proc (list inputT) outputT))
+
+(def: #export (binary subjectT paramT outputT proc)
+  (-> Type Type Type Text ///.Analysis)
+  (simple proc (list subjectT paramT) outputT))
+
+(def: #export (trinary subjectT param0T param1T outputT proc)
+  (-> Type Type Type Type Text ///.Analysis)
+  (simple proc (list subjectT param0T param1T) outputT))
+
+## [Analysers]
+## "lux is" represents reference/pointer equality.
+(def: (lux//is proc)
+  (-> Text ///.Analysis)
+  (function [analyse eval args]
+    (do macro.Monad<Meta>
+      [[var-id varT] (&.with-type-env tc.var)]
+      ((binary varT varT Bool proc)
+       analyse eval args))))
+
+## "lux try" provides a simple way to interact with the host platform's
+## error-handling facilities.
+(def: (lux//try proc)
+  (-> Text ///.Analysis)
+  (function [analyse eval args]
+    (case args
+      (^ (list opC))
+      (do macro.Monad<Meta>
+        [[var-id varT] (&.with-type-env tc.var)
+         _ (&.infer (type (Either Text varT)))
+         opA (&.with-type (type (io.IO varT))
+               (analyse opC))]
+        (wrap (la.procedure proc (list opA))))
+      
+      _
+      (&.throw Incorrect-Procedure-Arity (wrong-arity proc +1 (list.size args))))))
+
+(def: (lux//function proc)
+  (-> Text ///.Analysis)
+  (function [analyse eval args]
+    (case args
+      (^ (list [_ (#.Symbol ["" func-name])]
+               [_ (#.Symbol ["" arg-name])]
+               body))
+      (functionA.analyse-function analyse func-name arg-name body)
+      
+      _
+      (&.throw Incorrect-Procedure-Arity (wrong-arity proc +3 (list.size args))))))
+
+(def: (lux//case proc)
+  (-> Text ///.Analysis)
+  (function [analyse eval args]
+    (case args
+      (^ (list input [_ (#.Record branches)]))
+      (caseA.analyse-case analyse input branches)
+      
+      _
+      (&.throw Incorrect-Procedure-Arity (wrong-arity proc +2 (list.size args))))))
+
+(def: (lux//in-module proc)
+  (-> Text ///.Analysis)
+  (function [analyse eval argsC+]
+    (case argsC+
+      (^ (list [_ (#.Text module-name)] exprC))
+      (&.with-current-module module-name
+        (analyse exprC))
+      
+      _
+      (&.throw Invalid-Syntax (format "Procedure: " proc "\n"
+                                      "   Inputs:" (|> argsC+
+                                                       list.enumerate
+                                                       (list/map (function [[idx argC]]
+                                                                   (format "\n  " (%n idx) " " (%code argC))))
+                                                       (text.join-with "")) "\n")))))
+
+(do-template [<name> <analyser>]
+  [(def: (<name> proc)
+     (-> Text ///.Analysis)
+     (function [analyse eval args]
+       (case args
+         (^ (list typeC valueC))
+         (<analyser> analyse eval typeC valueC)
+         
+         _
+         (&.throw Incorrect-Procedure-Arity (wrong-arity proc +2 (list.size args))))))]
+
+  [lux//check typeA.analyse-check]
+  [lux//coerce typeA.analyse-coerce])
+
+(def: (lux//check//type proc)
+  (-> Text ///.Analysis)
+  (function [analyse eval args]
+    (case args
+      (^ (list valueC))
+      (do macro.Monad<Meta>
+        [_ (&.infer (type Type))
+         valueA (&.with-type Type
+                  (analyse valueC))]
+        (wrap valueA))
+      
+      _
+      (&.throw Incorrect-Procedure-Arity (wrong-arity proc +1 (list.size args))))))
+
+(def: lux-procs
+  Bundle
+  (|> (dict.new text.Hash<Text>)
+      (install "is" lux//is)
+      (install "try" lux//try)
+      (install "function" lux//function)
+      (install "case" lux//case)
+      (install "check" lux//check)
+      (install "coerce" lux//coerce)
+      (install "check type" lux//check//type)
+      (install "in-module" lux//in-module)))
+
+(def: io-procs
+  Bundle
+  (<| (prefix "io")
+      (|> (dict.new text.Hash<Text>)
+          (install "log" (unary Text Unit))
+          (install "error" (unary Text Bottom))
+          (install "exit" (unary Int Bottom))
+          (install "current-time" (nullary Int)))))
+
+(def: bit-procs
+  Bundle
+  (<| (prefix "bit")
+      (|> (dict.new text.Hash<Text>)
+          (install "count" (unary Nat Nat))
+          (install "and" (binary Nat Nat Nat))
+          (install "or" (binary Nat Nat Nat))
+          (install "xor" (binary Nat Nat Nat))
+          (install "shift-left" (binary Nat Nat Nat))
+          (install "unsigned-shift-right" (binary Nat Nat Nat))
+          (install "shift-right" (binary Int Nat Int))
+          )))
+
+(def: nat-procs
+  Bundle
+  (<| (prefix "nat")
+      (|> (dict.new text.Hash<Text>)
+          (install "+" (binary Nat Nat Nat))
+          (install "-" (binary Nat Nat Nat))
+          (install "*" (binary Nat Nat Nat))
+          (install "/" (binary Nat Nat Nat))
+          (install "%" (binary Nat Nat Nat))
+          (install "=" (binary Nat Nat Bool))
+          (install "<" (binary Nat Nat Bool))
+          (install "min" (nullary Nat))
+          (install "max" (nullary Nat))
+          (install "to-int" (unary Nat Int))
+          (install "char" (unary Nat Text)))))
+
+(def: int-procs
+  Bundle
+  (<| (prefix "int")
+      (|> (dict.new text.Hash<Text>)
+          (install "+" (binary Int Int Int))
+          (install "-" (binary Int Int Int))
+          (install "*" (binary Int Int Int))
+          (install "/" (binary Int Int Int))
+          (install "%" (binary Int Int Int))
+          (install "=" (binary Int Int Bool))
+          (install "<" (binary Int Int Bool))
+          (install "min" (nullary Int))
+          (install "max" (nullary Int))
+          (install "to-nat" (unary Int Nat))
+          (install "to-frac" (unary Int Frac)))))
+
+(def: deg-procs
+  Bundle
+  (<| (prefix "deg")
+      (|> (dict.new text.Hash<Text>)
+          (install "+" (binary Deg Deg Deg))
+          (install "-" (binary Deg Deg Deg))
+          (install "*" (binary Deg Deg Deg))
+          (install "/" (binary Deg Deg Deg))
+          (install "%" (binary Deg Deg Deg))
+          (install "=" (binary Deg Deg Bool))
+          (install "<" (binary Deg Deg Bool))
+          (install "scale" (binary Deg Nat Deg))
+          (install "reciprocal" (binary Deg Nat Deg))
+          (install "min" (nullary Deg))
+          (install "max" (nullary Deg))
+          (install "to-frac" (unary Deg Frac)))))
+
+(def: frac-procs
+  Bundle
+  (<| (prefix "frac")
+      (|> (dict.new text.Hash<Text>)
+          (install "+" (binary Frac Frac Frac))
+          (install "-" (binary Frac Frac Frac))
+          (install "*" (binary Frac Frac Frac))
+          (install "/" (binary Frac Frac Frac))
+          (install "%" (binary Frac Frac Frac))
+          (install "=" (binary Frac Frac Bool))
+          (install "<" (binary Frac Frac Bool))
+          (install "smallest" (nullary Frac))
+          (install "min" (nullary Frac))
+          (install "max" (nullary Frac))
+          (install "not-a-number" (nullary Frac))
+          (install "positive-infinity" (nullary Frac))
+          (install "negative-infinity" (nullary Frac))
+          (install "to-deg" (unary Frac Deg))
+          (install "to-int" (unary Frac Int))
+          (install "encode" (unary Frac Text))
+          (install "decode" (unary Text (type (Maybe Frac)))))))
+
+(def: text-procs
+  Bundle
+  (<| (prefix "text")
+      (|> (dict.new text.Hash<Text>)
+          (install "=" (binary Text Text Bool))
+          (install "<" (binary Text Text Bool))
+          (install "concat" (binary Text Text Text))
+          (install "index" (trinary Text Text Nat (type (Maybe Nat))))
+          (install "size" (unary Text Nat))
+          (install "hash" (unary Text Nat))
+          (install "replace-once" (trinary Text Text Text Text))
+          (install "replace-all" (trinary Text Text Text Text))
+          (install "char" (binary Text Nat (type (Maybe Nat))))
+          (install "clip" (trinary Text Nat Nat (type (Maybe Text))))
+          (install "upper" (unary Text Text))
+          (install "lower" (unary Text Text))
+          )))
+
+(def: (array//get proc)
+  (-> Text ///.Analysis)
+  (function [analyse eval args]
+    (do macro.Monad<Meta>
+      [[var-id varT] (&.with-type-env tc.var)]
+      ((binary (type (Array varT)) Nat (type (Maybe varT)) proc)
+       analyse eval args))))
+
+(def: (array//put proc)
+  (-> Text ///.Analysis)
+  (function [analyse eval args]
+    (do macro.Monad<Meta>
+      [[var-id varT] (&.with-type-env tc.var)]
+      ((trinary (type (Array varT)) Nat varT (type (Array varT)) proc)
+       analyse eval args))))
+
+(def: (array//remove proc)
+  (-> Text ///.Analysis)
+  (function [analyse eval args]
+    (do macro.Monad<Meta>
+      [[var-id varT] (&.with-type-env tc.var)]
+      ((binary (type (Array varT)) Nat (type (Array varT)) proc)
+       analyse eval args))))
+
+(def: array-procs
+  Bundle
+  (<| (prefix "array")
+      (|> (dict.new text.Hash<Text>)
+          (install "new" (unary Nat Array))
+          (install "get" array//get)
+          (install "put" array//put)
+          (install "remove" array//remove)
+          (install "size" (unary (type (Ex [a] (Array a))) Nat))
+          )))
+
+(def: math-procs
+  Bundle
+  (<| (prefix "math")
+      (|> (dict.new text.Hash<Text>)
+          (install "cos" (unary Frac Frac))
+          (install "sin" (unary Frac Frac))
+          (install "tan" (unary Frac Frac))
+          (install "acos" (unary Frac Frac))
+          (install "asin" (unary Frac Frac))
+          (install "atan" (unary Frac Frac))
+          (install "cosh" (unary Frac Frac))
+          (install "sinh" (unary Frac Frac))
+          (install "tanh" (unary Frac Frac))
+          (install "exp" (unary Frac Frac))
+          (install "log" (unary Frac Frac))
+          (install "root2" (unary Frac Frac))
+          (install "root3" (unary Frac Frac))
+          (install "ceil" (unary Frac Frac))
+          (install "floor" (unary Frac Frac))
+          (install "round" (unary Frac Frac))
+          (install "atan2" (binary Frac Frac Frac))
+          (install "pow" (binary Frac Frac Frac))
+          )))
+
+(def: (atom-new proc)
+  (-> Text ///.Analysis)
+  (function [analyse eval args]
+    (case args
+      (^ (list initC))
+      (do macro.Monad<Meta>
+        [[var-id varT] (&.with-type-env tc.var)
+         _ (&.infer (type (Atom varT)))
+         initA (&.with-type varT
+                 (analyse initC))]
+        (wrap (la.procedure proc (list initA))))
+      
+      _
+      (&.throw Incorrect-Procedure-Arity (wrong-arity proc +1 (list.size args))))))
+
+(def: (atom-read proc)
+  (-> Text ///.Analysis)
+  (function [analyse eval args]
+    (do macro.Monad<Meta>
+      [[var-id varT] (&.with-type-env tc.var)]
+      ((unary (type (Atom varT)) varT proc)
+       analyse eval args))))
+
+(def: (atom//compare-and-swap proc)
+  (-> Text ///.Analysis)
+  (function [analyse eval args]
+    (do macro.Monad<Meta>
+      [[var-id varT] (&.with-type-env tc.var)]
+      ((trinary (type (Atom varT)) varT varT Bool proc)
+       analyse eval args))))
+
+(def: atom-procs
+  Bundle
+  (<| (prefix "atom")
+      (|> (dict.new text.Hash<Text>)
+          (install "new" atom-new)
+          (install "read" atom-read)
+          (install "compare-and-swap" atom//compare-and-swap)
+          )))
+
+(def: process-procs
+  Bundle
+  (<| (prefix "process")
+      (|> (dict.new text.Hash<Text>)
+          (install "concurrency-level" (nullary Nat))
+          (install "future" (unary (type (io.IO Top)) Unit))
+          (install "schedule" (binary Nat (type (io.IO Top)) Unit))
+          )))
+
+(def: #export procedures
+  Bundle
+  (<| (prefix "lux")
+      (|> (dict.new text.Hash<Text>)
+          (dict.merge lux-procs)
+          (dict.merge bit-procs)
+          (dict.merge nat-procs)
+          (dict.merge int-procs)
+          (dict.merge deg-procs)
+          (dict.merge frac-procs)
+          (dict.merge text-procs)
+          (dict.merge array-procs)
+          (dict.merge math-procs)
+          (dict.merge atom-procs)
+          (dict.merge process-procs)
+          (dict.merge io-procs))))