1 files changed, 0 insertions, 418 deletions
diff --git a/new-luxc/source/luxc/analyser/procedure/common.lux b/new-luxc/source/luxc/analyser/procedure/common.lux
deleted file mode 100644
index 0fad41958..000000000
--- a/new-luxc/source/luxc/analyser/procedure/common.lux
+++ /dev/null
@@ -1,418 +0,0 @@
-(;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])
-        (analyser ["&;" 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))))