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. --- new-luxc/source/luxc/analyser/procedure/common.lux | 418 --------------------- 1 file changed, 418 deletions(-) delete mode 100644 new-luxc/source/luxc/analyser/procedure/common.lux (limited to 'new-luxc/source/luxc/analyser/procedure/common.lux') 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] - [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))) - -(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