From 15121222d570f8fe3c5a326208e4f0bad737e63c Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Tue, 31 Oct 2017 23:39:49 -0400 Subject: - Re-organized analysis. --- .../source/luxc/lang/analysis/procedure/common.lux | 418 +++++++++++++++++++++ 1 file changed, 418 insertions(+) create mode 100644 new-luxc/source/luxc/lang/analysis/procedure/common.lux (limited to 'new-luxc/source/luxc/lang/analysis/procedure/common.lux') 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] + [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))) + +(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 + [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 + [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 [ ] + [(def: ( proc) + (-> Text Proc) + (function [analyse eval args] + (&common;with-var + (function [[var-id varT]] + (case args + (^ (list typeC valueC)) + ( 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 + [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) + (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) + (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) + (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 "to-text" (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 "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) + (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 Proc) + (function [analyse eval args] + (&common;with-var + (function [[var-id varT]] + (case args + (^ (list initC)) + (do meta;Monad + [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) + (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