aboutsummaryrefslogtreecommitdiff
path: root/new-luxc/source/luxc/analyser/procedure/common.lux
diff options
context:
space:
mode:
Diffstat (limited to 'new-luxc/source/luxc/analyser/procedure/common.lux')
-rw-r--r--new-luxc/source/luxc/analyser/procedure/common.lux418
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))))