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/analysis/procedure/common.lux | 421 --------------------- 1 file changed, 421 deletions(-) delete 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 deleted file mode 100644 index ecdcd0bfd..000000000 --- a/new-luxc/source/luxc/lang/analysis/procedure/common.lux +++ /dev/null @@ -1,421 +0,0 @@ -(.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 Proc - (-> &.Analyser &.Eval (List Code) (Meta la.Analysis))) - -(type: #export Bundle - (Dict Text (-> Text Proc))) - -(def: #export (install name unnamed) - (-> Text (-> Text Proc) - (-> 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 Proc) - (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 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] - (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 Proc) - (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 Proc) - (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 Proc) - (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 Proc) - (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 Proc) - (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 Proc) - (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 Proc) - (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 Proc) - (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 Proc) - (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 Proc) - (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 Proc) - (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 Proc) - (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