diff options
Diffstat (limited to 'stdlib/source/lux/lang/extension/analysis/common.lux')
-rw-r--r-- | stdlib/source/lux/lang/extension/analysis/common.lux | 444 |
1 files changed, 0 insertions, 444 deletions
diff --git a/stdlib/source/lux/lang/extension/analysis/common.lux b/stdlib/source/lux/lang/extension/analysis/common.lux deleted file mode 100644 index 3faae601b..000000000 --- a/stdlib/source/lux/lang/extension/analysis/common.lux +++ /dev/null @@ -1,444 +0,0 @@ -(.module: - lux - (lux (control [monad #+ do] - ["ex" exception #+ exception:] - [thread]) - (concurrency [atom #+ Atom]) - (data [text] - text/format - (coll [list "list/" Functor<List>] - [array] - (dictionary ["dict" unordered #+ Dict]))) - [macro] - (macro [code]) - [lang] - (lang (type ["tc" check]) - [".L" analysis] - (analysis [".A" type] - [".A" case] - [".A" function])) - [io]) - [///]) - -(exception: #export (incorrect-extension-arity {name Text} {arity Nat} {args Nat}) - (ex.report ["Extension" (%t name)] - ["Expected arity" (|> arity .int %i)] - ["Actual arity" (|> args .int %i)])) - -(exception: #export (invalid-syntax {name Text} {arguments (List Code)}) - (ex.report ["Extension" name] - ["Inputs" (|> arguments - list.enumerate - (list/map (function (_ [idx argC]) - (format "\n " (%n idx) " " (%code argC)))) - (text.join-with ""))])) - -## [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: (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> - [_ (typeA.infer outputT) - argsA (monad.map @ - (function (_ [argT argC]) - (typeA.with-type argT - (analyse argC))) - (list.zip2 inputsT+ args))] - (wrap (#analysisL.Extension proc argsA))) - (lang.throw incorrect-extension-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] (typeA.with-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] (typeA.with-env tc.var) - _ (typeA.infer (type (Either Text varT))) - opA (typeA.with-type (type (io.IO varT)) - (analyse opC))] - (wrap (#analysisL.Extension proc (list opA)))) - - _ - (lang.throw incorrect-extension-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.function analyse func-name arg-name body) - - _ - (lang.throw incorrect-extension-arity [proc +3 (list.size args)])))) - -(def: (lux//case proc) - (-> Text ///.Analysis) - (function (_ analyse eval args) - (case args - (^ (list input [_ (#.Record branches)])) - (caseA.case analyse input branches) - - _ - (lang.throw incorrect-extension-arity [proc +2 (list.size args)])))) - -(def: (lux//in-module proc) - (-> Text ///.Analysis) - (function (_ analyse eval argsC+) - (case argsC+ - (^ (list [_ (#.Text module-name)] exprC)) - (lang.with-current-module module-name - (analyse exprC)) - - _ - (lang.throw invalid-syntax [proc argsC+])))) - -(do-template [<name> <type>] - [(def: (<name> proc) - (-> Text ///.Analysis) - (function (_ analyse eval args) - (case args - (^ (list typeC valueC)) - (do macro.Monad<Meta> - [actualT (eval Type typeC) - _ (typeA.infer (:! Type actualT))] - (typeA.with-type <type> - (analyse valueC))) - - _ - (lang.throw incorrect-extension-arity [proc +2 (list.size args)]))))] - - [lux//check (:! Type actualT)] - [lux//coerce Any] - ) - -(def: (lux//check//type proc) - (-> Text ///.Analysis) - (function (_ analyse eval args) - (case args - (^ (list valueC)) - (do macro.Monad<Meta> - [_ (typeA.infer Type) - valueA (typeA.with-type Type - (analyse valueC))] - (wrap valueA)) - - _ - (lang.throw incorrect-extension-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 Any)) - (install "error" (unary Text Nothing)) - (install "exit" (unary Int Nothing)) - (install "current-time" (nullary Int))))) - -(def: bit-procs - Bundle - (<| (prefix "bit") - (|> (dict.new text.Hash<Text>) - (install "and" (binary Nat Nat Nat)) - (install "or" (binary Nat Nat Nat)) - (install "xor" (binary Nat Nat Nat)) - (install "left-shift" (binary Nat Nat Nat)) - (install "logical-right-shift" (binary Nat Nat Nat)) - (install "arithmetic-right-shift" (binary Int Nat Int)) - ))) - -(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)) - (install "char" (unary Int Text))))) - -(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)))) - ))) - -(def: (array//get proc) - (-> Text ///.Analysis) - (function (_ analyse eval args) - (do macro.Monad<Meta> - [[var-id varT] (typeA.with-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] (typeA.with-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] (typeA.with-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 "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] (typeA.with-env tc.var) - _ (typeA.infer (type (Atom varT))) - initA (typeA.with-type varT - (analyse initC))] - (wrap (#analysisL.Extension proc (list initA)))) - - _ - (lang.throw incorrect-extension-arity [proc +1 (list.size args)])))) - -(def: (atom-read proc) - (-> Text ///.Analysis) - (function (_ analyse eval args) - (do macro.Monad<Meta> - [[var-id varT] (typeA.with-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] (typeA.with-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: (box//new proc) - (-> Text ///.Analysis) - (function (_ analyse eval args) - (case args - (^ (list initC)) - (do macro.Monad<Meta> - [[var-id varT] (typeA.with-env tc.var) - _ (typeA.infer (type (All [!] (thread.Box ! varT)))) - initA (typeA.with-type varT - (analyse initC))] - (wrap (#analysisL.Extension proc (list initA)))) - - _ - (lang.throw incorrect-extension-arity [proc +1 (list.size args)])))) - -(def: (box//read proc) - (-> Text ///.Analysis) - (function (_ analyse eval args) - (do macro.Monad<Meta> - [[thread-id threadT] (typeA.with-env tc.var) - [var-id varT] (typeA.with-env tc.var)] - ((unary (type (thread.Box threadT varT)) varT proc) - analyse eval args)))) - -(def: (box//write proc) - (-> Text ///.Analysis) - (function (_ analyse eval args) - (do macro.Monad<Meta> - [[thread-id threadT] (typeA.with-env tc.var) - [var-id varT] (typeA.with-env tc.var)] - ((binary varT (type (thread.Box threadT varT)) Any proc) - analyse eval args)))) - -(def: box-procs - Bundle - (<| (prefix "box") - (|> (dict.new text.Hash<Text>) - (install "new" box//new) - (install "read" box//read) - (install "write" box//write) - ))) - -(def: process-procs - Bundle - (<| (prefix "process") - (|> (dict.new text.Hash<Text>) - (install "parallelism-level" (nullary Nat)) - (install "schedule" (binary Nat (type (io.IO Any)) Any)) - ))) - -(def: #export extensions - Bundle - (<| (prefix "lux") - (|> (dict.new text.Hash<Text>) - (dict.merge lux-procs) - (dict.merge bit-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 box-procs) - (dict.merge process-procs) - (dict.merge io-procs)))) |