1 files changed, 418 insertions, 0 deletions
diff --git a/new-luxc/source/luxc/lang/analysis/procedure/common.lux b/new-luxc/source/luxc/lang/analysis/procedure/common.lux
new file mode 100644
index 000000000..e06a3d2b4
--- /dev/null
+++ b/new-luxc/source/luxc/lang/analysis/procedure/common.lux
@@ -0,0 +1,418 @@
+(;module:
+  lux
+  (lux (control [monad #+ do])
+       (concurrency ["A" atom])
+       (data [text]
+             text/format
+             (coll [list "list/" Functor<List>]
+                   [array]
+                   [dict #+ Dict]))
+       [meta]
+       (meta [code]
+             (type ["tc" check]))
+       [io])
+  (luxc ["&" base]
+        (lang ["la" analysis]
+              (analysis ["&;" common]
+                        [";A" function]
+                        [";A" case]
+                        [";A" type]))))
+
+## [Utils]
+(type: #export Proc
+  (-> &;Analyser &;Eval (List Code) (Meta la;Analysis)))
+
+(type: #export Bundle
+  (Dict Text Proc))
+
+(def: #export (install name unnamed)
+  (-> Text (-> Text Proc)
+      (-> Bundle Bundle))
+  (dict;put name (unnamed name)))
+
+(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 "Wrong arity for " (%t proc) "\n"
+          "Expected: " (|> expected nat-to-int %i) "\n"
+          "  Actual: " (|> actual nat-to-int %i)))
+
+(def: (simple proc input-types output-type)
+  (-> Text (List Type) Type Proc)
+  (let [num-expected (list;size input-types)]
+    (function [analyse eval args]
+      (let [num-actual (list;size args)]
+        (if (n.= num-expected num-actual)
+          (do meta;Monad<Meta>
+            [argsA (monad;map @
+                              (function [[argT argC]]
+                                (&;with-expected-type argT
+                                  (analyse argC)))
+                              (list;zip2 input-types args))
+             expected meta;expected-type
+             _ (&;with-type-env
+                 (tc;check expected output-type))]
+            (wrap (la;procedure proc argsA)))
+          (&;fail (wrong-arity proc num-expected num-actual)))))))
+
+(def: #export (nullary valueT proc)
+  (-> Type Text Proc)
+  (simple proc (list) valueT))
+
+(def: #export (unary inputT outputT proc)
+  (-> Type Type Text Proc)
+  (simple proc (list inputT) outputT))
+
+(def: #export (binary subjectT paramT outputT proc)
+  (-> Type Type Type Text Proc)
+  (simple proc (list subjectT paramT) outputT))
+
+(def: #export (trinary subjectT param0T param1T outputT proc)
+  (-> Type Type Type Type Text Proc)
+  (simple proc (list subjectT param0T param1T) outputT))
+
+## [Analysers]
+## "lux is" represents reference/pointer equality.
+(def: (lux-is proc)
+  (-> Text Proc)
+  (function [analyse eval args]
+    (&common;with-var
+      (function [[var-id varT]]
+        ((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 Proc)
+  (function [analyse eval args]
+    (&common;with-var
+      (function [[var-id varT]]
+        (case args
+          (^ (list opC))
+          (do meta;Monad<Meta>
+            [opA (&;with-expected-type (type (io;IO varT))
+                   (analyse opC))
+             outputT (&;with-type-env
+                       (tc;clean var-id (type (Either Text varT))))
+             expected meta;expected-type
+             _ (&;with-type-env
+                 (tc;check expected outputT))]
+            (wrap (la;procedure proc (list opA))))
+          
+          _
+          (&;fail (wrong-arity proc +1 (list;size args))))))))
+
+(def: (lux//function proc)
+  (-> Text Proc)
+  (function [analyse eval args]
+    (&common;with-var
+      (function [[var-id varT]]
+        (case args
+          (^ (list [_ (#;Symbol ["" func-name])]
+                   [_ (#;Symbol ["" arg-name])]
+                   body))
+          (functionA;analyse-function analyse func-name arg-name body)
+          
+          _
+          (&;fail (wrong-arity proc +3 (list;size args))))))))
+
+(def: (lux//case proc)
+  (-> Text Proc)
+  (function [analyse eval args]
+    (&common;with-var
+      (function [[var-id varT]]
+        (case args
+          (^ (list input [_ (#;Record branches)]))
+          (caseA;analyse-case analyse input branches)
+          
+          _
+          (&;fail (wrong-arity proc +2 (list;size args))))))))
+
+(do-template [<name> <analyser>]
+  [(def: (<name> proc)
+     (-> Text Proc)
+     (function [analyse eval args]
+       (&common;with-var
+         (function [[var-id varT]]
+           (case args
+             (^ (list typeC valueC))
+             (<analyser> analyse eval typeC valueC)
+             
+             _
+             (&;fail (wrong-arity proc +2 (list;size args))))))))]
+
+  [lux//check typeA;analyse-check]
+  [lux//coerce typeA;analyse-coerce])
+
+(def: (lux//check//type proc)
+  (-> Text Proc)
+  (function [analyse eval args]
+    (case args
+      (^ (list valueC))
+      (do meta;Monad<Meta>
+        [valueA (&;with-expected-type Type
+                  (analyse valueC))
+         expected meta;expected-type
+         _ (&;with-type-env
+             (tc;check expected Type))]
+        (wrap valueA))
+      
+      _
+      (&;fail (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)))
+
+(def: io-procs
+  Bundle
+  (<| (prefix "io")
+      (|> (dict;new text;Hash<Text>)
+          (install "log" (unary Text Unit))
+          (install "error" (unary Text Bottom))
+          (install "exit" (unary Nat 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 "to-text" (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 "prepend" (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 Nat))
+          (install "clip" (trinary Text Nat Nat Text))
+          )))
+
+(def: (array-get proc)
+  (-> Text Proc)
+  (function [analyse eval args]
+    (&common;with-var
+      (function [[var-id varT]]
+        ((binary Nat (type (Array varT)) varT proc)
+         analyse eval args)))))
+
+(def: (array-put proc)
+  (-> Text Proc)
+  (function [analyse eval args]
+    (&common;with-var
+      (function [[var-id varT]]
+        ((trinary Nat varT (type (Array varT)) (type (Array varT)) proc)
+         analyse eval args)))))
+
+(def: (array-remove proc)
+  (-> Text Proc)
+  (function [analyse eval args]
+    (&common;with-var
+      (function [[var-id varT]]
+        ((binary Nat (type (Array varT)) (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 Proc)
+  (function [analyse eval args]
+    (&common;with-var
+      (function [[var-id varT]]
+        (case args
+          (^ (list initC))
+          (do meta;Monad<Meta>
+            [initA (&;with-expected-type varT
+                     (analyse initC))
+             outputT (&;with-type-env
+                       (tc;clean var-id (type (A;Atom varT))))
+             expected meta;expected-type
+             _ (&;with-type-env
+                 (tc;check expected outputT))]
+            (wrap (la;procedure proc (list initA))))
+          
+          _
+          (&;fail (wrong-arity proc +1 (list;size args))))))))
+
+(def: (atom-read proc)
+  (-> Text Proc)
+  (function [analyse eval args]
+    (&common;with-var
+      (function [[var-id varT]]
+        ((unary (type (A;Atom varT)) varT proc)
+         analyse eval args)))))
+
+(def: (atom-compare-and-swap proc)
+  (-> Text Proc)
+  (function [analyse eval args]
+    (&common;with-var
+      (function [[var-id varT]]
+        ((trinary varT varT (type (A;Atom 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))))