From 8a51602b3507a18a5ffae1710ba4e915cf31fe39 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Tue, 5 Dec 2017 16:40:15 -0400 Subject: - All analysis procedures have been turned into extensions. --- .../source/luxc/lang/extension/analysis/common.lux | 419 +++++++++++++++++++++ 1 file changed, 419 insertions(+) create mode 100644 new-luxc/source/luxc/lang/extension/analysis/common.lux (limited to 'new-luxc/source/luxc/lang/extension/analysis/common.lux') 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] + [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))) + +(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 + [_ (&.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 + [[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 + [[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 [ ] + [(def: ( proc) + (-> Text ///.Analysis) + (function [analyse eval args] + (case args + (^ (list typeC valueC)) + ( 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 + [_ (&.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) + (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) + (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) + (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) + (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) + (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) + (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) + (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) + (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 + [[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 + [[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 + [[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) + (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) + (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 + [[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 + [[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 + [[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) + (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) + (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) + (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)))) -- cgit v1.2.3