diff options
Diffstat (limited to 'stdlib/source/lux/language/compiler/extension')
4 files changed, 687 insertions, 692 deletions
diff --git a/stdlib/source/lux/language/compiler/extension/analysis.lux b/stdlib/source/lux/language/compiler/extension/analysis.lux index ba37b4578..0f57de1ff 100644 --- a/stdlib/source/lux/language/compiler/extension/analysis.lux +++ b/stdlib/source/lux/language/compiler/extension/analysis.lux @@ -1,20 +1,15 @@ (.module: [lux #* [data - [text] [collection - [list ("list/" Functor<List>)] - ["dict" dictionary (#+ Dictionary)]]]] - [///analysis (#+ Analysis State)] - [///synthesis (#+ Synthesis)] - [//] - [/common] - [/host]) + [dictionary]]]] + [/// + [analysis (#+ Bundle)]] + [/ + [common] + [host]]) -(def: #export defaults - (//.Bundle State Analysis Synthesis) - (|> /common.extensions - (dict.merge /host.extensions) - dict.entries - (list/map (function (_ [name proc]) [name (proc name)])) - (dict.from-list text.Hash<Text>))) +(def: #export bundle + Bundle + (dictionary.merge host.bundle + common.bundle)) diff --git a/stdlib/source/lux/language/compiler/extension/analysis/common.lux b/stdlib/source/lux/language/compiler/extension/analysis/common.lux index 0dac69ced..55d479052 100644 --- a/stdlib/source/lux/language/compiler/extension/analysis/common.lux +++ b/stdlib/source/lux/language/compiler/extension/analysis/common.lux @@ -15,23 +15,19 @@ ["." language [type ["tc" check]]] [io (#+ IO)]] - [////] - [//// - [analysis (#+ Analysis) + ["." //// + [analysis (#+ Analysis Bundle) [".A" type] [".A" case] [".A" function]]] - [///] - [///bundle]) - -(type: Handler - (///.Handler .Lux .Code Analysis)) + ["." /// + [bundle]]) ## [Utils] -(def: (simple extension inputsT+ outputT) - (-> Text (List Type) Type ..Handler) +(def: (simple inputsT+ outputT) + (-> (List Type) Type analysis.Handler) (let [num-expected (list.size inputsT+)] - (function (_ analyse args) + (function (_ extension-name analyse args) (let [num-actual (list.size args)] (if (n/= num-expected num-actual) (do ////.Monad<Operation> @@ -41,40 +37,40 @@ (typeA.with-type argT (analyse argC))) (list.zip2 inputsT+ args))] - (wrap (#///.Extension extension argsA))) - (language.throw ///bundle.incorrect-arity [extension num-expected num-actual])))))) + (wrap (#analysis.Extension extension-name argsA))) + (////.throw bundle.incorrect-arity [extension-name num-expected num-actual])))))) -(def: #export (nullary valueT extension) - (-> Type Text ..Handler) - (simple extension (list) valueT)) +(def: #export (nullary valueT) + (-> Type analysis.Handler) + (simple (list) valueT)) -(def: #export (unary inputT outputT extension) - (-> Type Type Text ..Handler) - (simple extension (list inputT) outputT)) +(def: #export (unary inputT outputT) + (-> Type Type analysis.Handler) + (simple (list inputT) outputT)) -(def: #export (binary subjectT paramT outputT extension) - (-> Type Type Type Text ..Handler) - (simple extension (list subjectT paramT) outputT)) +(def: #export (binary subjectT paramT outputT) + (-> Type Type Type analysis.Handler) + (simple (list subjectT paramT) outputT)) -(def: #export (trinary subjectT param0T param1T outputT extension) - (-> Type Type Type Type Text ..Handler) - (simple extension (list subjectT param0T param1T) outputT)) +(def: #export (trinary subjectT param0T param1T outputT) + (-> Type Type Type Type analysis.Handler) + (simple (list subjectT param0T param1T) outputT)) ## [Analysers] ## "lux is" represents reference/pointer equality. -(def: (lux//is extension) - (-> Text ..Handler) - (function (_ analyse args) +(def: lux::is + analysis.Handler + (function (_ extension-name analyse args) (do ////.Monad<Operation> [[var-id varT] (typeA.with-env tc.var)] - ((binary varT varT Bool extension) + ((binary varT varT Bool extension-name) analyse args)))) ## "lux try" provides a simple way to interact with the host platform's ## error-handling facilities. -(def: (lux//try extension) - (-> Text ..Handler) - (function (_ analyse args) +(def: lux::try + analysis.Handler + (function (_ extension-name analyse args) (case args (^ (list opC)) (do ////.Monad<Operation> @@ -82,26 +78,26 @@ _ (typeA.infer (type (Either Text varT))) opA (typeA.with-type (type (IO varT)) (analyse opC))] - (wrap (#///.Extension extension (list opA)))) + (wrap (#analysis.Extension extension-name (list opA)))) _ - (language.throw ///bundle.incorrect-arity [extension +1 (list.size args)])))) + (////.throw bundle.incorrect-arity [extension-name +1 (list.size args)])))) -(def: (lux//in-module extension) - (-> Text ..Handler) - (function (_ analyse argsC+) +(def: lux::in-module + analysis.Handler + (function (_ extension-name analyse argsC+) (case argsC+ (^ (list [_ (#.Text module-name)] exprC)) - (language.with-current-module module-name + (analysis.with-current-module module-name (analyse exprC)) _ - (language.throw ///bundle.invalid-syntax [extension])))) + (////.throw bundle.invalid-syntax [extension-name])))) ## (do-template [<name> <type>] -## [(def: (<name> extension) -## (-> Text ..Handler) -## (function (_ analyse args) +## [(def: <name> +## analysis.Handler +## (function (_ extension-name analyse args) ## (case args ## (^ (list typeC valueC)) ## (do ////.Monad<Operation> @@ -111,15 +107,15 @@ ## (analyse valueC))) ## _ -## (language.throw ///bundle.incorrect-arity [extension +2 (list.size args)]))))] +## (////.throw bundle.incorrect-arity [extension-name +2 (list.size args)]))))] -## [lux//check (:coerce Type actualT)] -## [lux//coerce Any] +## [lux::check (:coerce Type actualT)] +## [lux::coerce Any] ## ) -(def: (lux//check//type extension) - (-> Text ..Handler) - (function (_ analyse args) +(def: lux::check::type + analysis.Handler + (function (_ extension-name analyse args) (case args (^ (list valueC)) (do ////.Monad<Operation> @@ -129,145 +125,145 @@ (wrap valueA)) _ - (language.throw ///bundle.incorrect-arity [extension +1 (list.size args)])))) - -(def: bundle/lux - ///.Bundle - (|> ///.fresh - (///bundle.install "is" lux//is) - (///bundle.install "try" lux//try) - (///bundle.install "check" lux//check) - (///bundle.install "coerce" lux//coerce) - (///bundle.install "check type" lux//check//type) - (///bundle.install "in-module" lux//in-module))) - -(def: bundle/io - ///.Bundle - (<| (///bundle.prefix "io") - (|> ///.fresh - (///bundle.install "log" (unary Text Any)) - (///bundle.install "error" (unary Text Nothing)) - (///bundle.install "exit" (unary Int Nothing)) - (///bundle.install "current-time" (nullary Int))))) - -(def: bundle/bit - ///.Bundle - (<| (///bundle.prefix "bit") - (|> ///.fresh - (///bundle.install "and" (binary Nat Nat Nat)) - (///bundle.install "or" (binary Nat Nat Nat)) - (///bundle.install "xor" (binary Nat Nat Nat)) - (///bundle.install "left-shift" (binary Nat Nat Nat)) - (///bundle.install "logical-right-shift" (binary Nat Nat Nat)) - (///bundle.install "arithmetic-right-shift" (binary Int Nat Int)) + (////.throw bundle.incorrect-arity [extension-name +1 (list.size args)])))) + +(def: bundle::lux + Bundle + (|> bundle.empty + (bundle.install "is" lux::is) + (bundle.install "try" lux::try) + ## (bundle.install "check" lux::check) + ## (bundle.install "coerce" lux::coerce) + (bundle.install "check type" lux::check::type) + (bundle.install "in-module" lux::in-module))) + +(def: bundle::io + Bundle + (<| (bundle.prefix "io") + (|> bundle.empty + (bundle.install "log" (unary Text Any)) + (bundle.install "error" (unary Text Nothing)) + (bundle.install "exit" (unary Int Nothing)) + (bundle.install "current-time" (nullary Int))))) + +(def: bundle::bit + Bundle + (<| (bundle.prefix "bit") + (|> bundle.empty + (bundle.install "and" (binary Nat Nat Nat)) + (bundle.install "or" (binary Nat Nat Nat)) + (bundle.install "xor" (binary Nat Nat Nat)) + (bundle.install "left-shift" (binary Nat Nat Nat)) + (bundle.install "logical-right-shift" (binary Nat Nat Nat)) + (bundle.install "arithmetic-right-shift" (binary Int Nat Int)) ))) -(def: bundle/int - ///.Bundle - (<| (///bundle.prefix "int") - (|> ///.fresh - (///bundle.install "+" (binary Int Int Int)) - (///bundle.install "-" (binary Int Int Int)) - (///bundle.install "*" (binary Int Int Int)) - (///bundle.install "/" (binary Int Int Int)) - (///bundle.install "%" (binary Int Int Int)) - (///bundle.install "=" (binary Int Int Bool)) - (///bundle.install "<" (binary Int Int Bool)) - (///bundle.install "to-frac" (unary Int Frac)) - (///bundle.install "char" (unary Int Text))))) - -(def: bundle/frac - ///.Bundle - (<| (///bundle.prefix "frac") - (|> ///.fresh - (///bundle.install "+" (binary Frac Frac Frac)) - (///bundle.install "-" (binary Frac Frac Frac)) - (///bundle.install "*" (binary Frac Frac Frac)) - (///bundle.install "/" (binary Frac Frac Frac)) - (///bundle.install "%" (binary Frac Frac Frac)) - (///bundle.install "=" (binary Frac Frac Bool)) - (///bundle.install "<" (binary Frac Frac Bool)) - (///bundle.install "smallest" (nullary Frac)) - (///bundle.install "min" (nullary Frac)) - (///bundle.install "max" (nullary Frac)) - (///bundle.install "to-rev" (unary Frac Rev)) - (///bundle.install "to-int" (unary Frac Int)) - (///bundle.install "encode" (unary Frac Text)) - (///bundle.install "decode" (unary Text (type (Maybe Frac))))))) - -(def: bundle/text - ///.Bundle - (<| (///bundle.prefix "text") - (|> ///.fresh - (///bundle.install "=" (binary Text Text Bool)) - (///bundle.install "<" (binary Text Text Bool)) - (///bundle.install "concat" (binary Text Text Text)) - (///bundle.install "index" (trinary Text Text Nat (type (Maybe Nat)))) - (///bundle.install "size" (unary Text Nat)) - (///bundle.install "char" (binary Text Nat (type (Maybe Nat)))) - (///bundle.install "clip" (trinary Text Nat Nat (type (Maybe Text)))) +(def: bundle::int + Bundle + (<| (bundle.prefix "int") + (|> bundle.empty + (bundle.install "+" (binary Int Int Int)) + (bundle.install "-" (binary Int Int Int)) + (bundle.install "*" (binary Int Int Int)) + (bundle.install "/" (binary Int Int Int)) + (bundle.install "%" (binary Int Int Int)) + (bundle.install "=" (binary Int Int Bool)) + (bundle.install "<" (binary Int Int Bool)) + (bundle.install "to-frac" (unary Int Frac)) + (bundle.install "char" (unary Int Text))))) + +(def: bundle::frac + Bundle + (<| (bundle.prefix "frac") + (|> bundle.empty + (bundle.install "+" (binary Frac Frac Frac)) + (bundle.install "-" (binary Frac Frac Frac)) + (bundle.install "*" (binary Frac Frac Frac)) + (bundle.install "/" (binary Frac Frac Frac)) + (bundle.install "%" (binary Frac Frac Frac)) + (bundle.install "=" (binary Frac Frac Bool)) + (bundle.install "<" (binary Frac Frac Bool)) + (bundle.install "smallest" (nullary Frac)) + (bundle.install "min" (nullary Frac)) + (bundle.install "max" (nullary Frac)) + (bundle.install "to-rev" (unary Frac Rev)) + (bundle.install "to-int" (unary Frac Int)) + (bundle.install "encode" (unary Frac Text)) + (bundle.install "decode" (unary Text (type (Maybe Frac))))))) + +(def: bundle::text + Bundle + (<| (bundle.prefix "text") + (|> bundle.empty + (bundle.install "=" (binary Text Text Bool)) + (bundle.install "<" (binary Text Text Bool)) + (bundle.install "concat" (binary Text Text Text)) + (bundle.install "index" (trinary Text Text Nat (type (Maybe Nat)))) + (bundle.install "size" (unary Text Nat)) + (bundle.install "char" (binary Text Nat (type (Maybe Nat)))) + (bundle.install "clip" (trinary Text Nat Nat (type (Maybe Text)))) ))) -(def: (array//get extension) - (-> Text ..Handler) - (function (_ analyse args) +(def: array::get + analysis.Handler + (function (_ extension-name analyse args) (do ////.Monad<Operation> [[var-id varT] (typeA.with-env tc.var)] - ((binary (type (Array varT)) Nat (type (Maybe varT)) extension) + ((binary (type (Array varT)) Nat (type (Maybe varT)) extension-name) analyse args)))) -(def: (array//put extension) - (-> Text ..Handler) - (function (_ analyse args) +(def: array::put + analysis.Handler + (function (_ extension-name analyse args) (do ////.Monad<Operation> [[var-id varT] (typeA.with-env tc.var)] - ((trinary (type (Array varT)) Nat varT (type (Array varT)) extension) + ((trinary (type (Array varT)) Nat varT (type (Array varT)) extension-name) analyse args)))) -(def: (array//remove extension) - (-> Text ..Handler) - (function (_ analyse args) +(def: array::remove + analysis.Handler + (function (_ extension-name analyse args) (do ////.Monad<Operation> [[var-id varT] (typeA.with-env tc.var)] - ((binary (type (Array varT)) Nat (type (Array varT)) extension) + ((binary (type (Array varT)) Nat (type (Array varT)) extension-name) analyse args)))) -(def: bundle/array - ///.Bundle - (<| (///bundle.prefix "array") - (|> ///.fresh - (///bundle.install "new" (unary Nat Array)) - (///bundle.install "get" array//get) - (///bundle.install "put" array//put) - (///bundle.install "remove" array//remove) - (///bundle.install "size" (unary (type (Ex [a] (Array a))) Nat)) +(def: bundle::array + Bundle + (<| (bundle.prefix "array") + (|> bundle.empty + (bundle.install "new" (unary Nat Array)) + (bundle.install "get" array::get) + (bundle.install "put" array::put) + (bundle.install "remove" array::remove) + (bundle.install "size" (unary (type (Ex [a] (Array a))) Nat)) ))) -(def: bundle/math - ///.Bundle - (<| (///bundle.prefix "math") - (|> ///.fresh - (///bundle.install "cos" (unary Frac Frac)) - (///bundle.install "sin" (unary Frac Frac)) - (///bundle.install "tan" (unary Frac Frac)) - (///bundle.install "acos" (unary Frac Frac)) - (///bundle.install "asin" (unary Frac Frac)) - (///bundle.install "atan" (unary Frac Frac)) - (///bundle.install "cosh" (unary Frac Frac)) - (///bundle.install "sinh" (unary Frac Frac)) - (///bundle.install "tanh" (unary Frac Frac)) - (///bundle.install "exp" (unary Frac Frac)) - (///bundle.install "log" (unary Frac Frac)) - (///bundle.install "ceil" (unary Frac Frac)) - (///bundle.install "floor" (unary Frac Frac)) - (///bundle.install "round" (unary Frac Frac)) - (///bundle.install "atan2" (binary Frac Frac Frac)) - (///bundle.install "pow" (binary Frac Frac Frac)) +(def: bundle::math + Bundle + (<| (bundle.prefix "math") + (|> bundle.empty + (bundle.install "cos" (unary Frac Frac)) + (bundle.install "sin" (unary Frac Frac)) + (bundle.install "tan" (unary Frac Frac)) + (bundle.install "acos" (unary Frac Frac)) + (bundle.install "asin" (unary Frac Frac)) + (bundle.install "atan" (unary Frac Frac)) + (bundle.install "cosh" (unary Frac Frac)) + (bundle.install "sinh" (unary Frac Frac)) + (bundle.install "tanh" (unary Frac Frac)) + (bundle.install "exp" (unary Frac Frac)) + (bundle.install "log" (unary Frac Frac)) + (bundle.install "ceil" (unary Frac Frac)) + (bundle.install "floor" (unary Frac Frac)) + (bundle.install "round" (unary Frac Frac)) + (bundle.install "atan2" (binary Frac Frac Frac)) + (bundle.install "pow" (binary Frac Frac Frac)) ))) -(def: (atom-new extension) - (-> Text ..Handler) - (function (_ analyse args) +(def: atom::new + analysis.Handler + (function (_ extension-name analyse args) (case args (^ (list initC)) (do ////.Monad<Operation> @@ -275,39 +271,39 @@ _ (typeA.infer (type (Atom varT))) initA (typeA.with-type varT (analyse initC))] - (wrap (#///.Extension extension (list initA)))) + (wrap (#analysis.Extension extension-name (list initA)))) _ - (language.throw ///bundle.incorrect-arity [extension +1 (list.size args)])))) + (////.throw bundle.incorrect-arity [extension-name +1 (list.size args)])))) -(def: (atom-read extension) - (-> Text ..Handler) - (function (_ analyse args) +(def: atom::read + analysis.Handler + (function (_ extension-name analyse args) (do ////.Monad<Operation> [[var-id varT] (typeA.with-env tc.var)] - ((unary (type (Atom varT)) varT extension) + ((unary (type (Atom varT)) varT extension-name) analyse args)))) -(def: (atom//compare-and-swap extension) - (-> Text ..Handler) - (function (_ analyse args) +(def: atom::compare-and-swap + analysis.Handler + (function (_ extension-name analyse args) (do ////.Monad<Operation> [[var-id varT] (typeA.with-env tc.var)] - ((trinary (type (Atom varT)) varT varT Bool extension) + ((trinary (type (Atom varT)) varT varT Bool extension-name) analyse args)))) -(def: bundle/atom - ///.Bundle - (<| (///bundle.prefix "atom") - (|> ///.fresh - (///bundle.install "new" atom-new) - (///bundle.install "read" atom-read) - (///bundle.install "compare-and-swap" atom//compare-and-swap) +(def: bundle::atom + Bundle + (<| (bundle.prefix "atom") + (|> bundle.empty + (bundle.install "new" atom::new) + (bundle.install "read" atom::read) + (bundle.install "compare-and-swap" atom::compare-and-swap) ))) -(def: (box//new extension) - (-> Text ..Handler) - (function (_ analyse args) +(def: box::new + analysis.Handler + (function (_ extension-name analyse args) (case args (^ (list initC)) (do ////.Monad<Operation> @@ -315,59 +311,59 @@ _ (typeA.infer (type (All [!] (Box ! varT)))) initA (typeA.with-type varT (analyse initC))] - (wrap (#///.Extension extension (list initA)))) + (wrap (#analysis.Extension extension-name (list initA)))) _ - (language.throw ///bundle.incorrect-arity [extension +1 (list.size args)])))) + (////.throw bundle.incorrect-arity [extension-name +1 (list.size args)])))) -(def: (box//read extension) - (-> Text ..Handler) - (function (_ analyse args) +(def: box::read + analysis.Handler + (function (_ extension-name analyse args) (do ////.Monad<Operation> [[thread-id threadT] (typeA.with-env tc.var) [var-id varT] (typeA.with-env tc.var)] - ((unary (type (Box threadT varT)) varT extension) + ((unary (type (Box threadT varT)) varT extension-name) analyse args)))) -(def: (box//write extension) - (-> Text ..Handler) - (function (_ analyse args) +(def: box::write + analysis.Handler + (function (_ extension-name analyse args) (do ////.Monad<Operation> [[thread-id threadT] (typeA.with-env tc.var) [var-id varT] (typeA.with-env tc.var)] - ((binary varT (type (Box threadT varT)) Any extension) + ((binary varT (type (Box threadT varT)) Any extension-name) analyse args)))) -(def: bundle/box - ///.Bundle - (<| (///bundle.prefix "box") - (|> ///.fresh - (///bundle.install "new" box//new) - (///bundle.install "read" box//read) - (///bundle.install "write" box//write) +(def: bundle::box + Bundle + (<| (bundle.prefix "box") + (|> bundle.empty + (bundle.install "new" box::new) + (bundle.install "read" box::read) + (bundle.install "write" box::write) ))) -(def: bundle/process - ///.Bundle - (<| (///bundle.prefix "process") - (|> ///.fresh - (///bundle.install "parallelism" (nullary Nat)) - (///bundle.install "schedule" (binary Nat (type (IO Any)) Any)) +(def: bundle::process + Bundle + (<| (bundle.prefix "process") + (|> bundle.empty + (bundle.install "parallelism" (nullary Nat)) + (bundle.install "schedule" (binary Nat (type (IO Any)) Any)) ))) (def: #export bundle - ///.Bundle - (<| (///bundle.prefix "lux") - (|> ///.fresh - (dict.merge bundle/lux) - (dict.merge bundle/bit) - (dict.merge bundle/int) - (dict.merge bundle/frac) - (dict.merge bundle/text) - (dict.merge bundle/array) - (dict.merge bundle/math) - (dict.merge bundle/atom) - (dict.merge bundle/box) - (dict.merge bundle/process) - (dict.merge bundle/io)) + Bundle + (<| (bundle.prefix "lux") + (|> bundle.empty + (dict.merge bundle::lux) + (dict.merge bundle::bit) + (dict.merge bundle::int) + (dict.merge bundle::frac) + (dict.merge bundle::text) + (dict.merge bundle::array) + (dict.merge bundle::math) + (dict.merge bundle::atom) + (dict.merge bundle::box) + (dict.merge bundle::process) + (dict.merge bundle::io)) )) diff --git a/stdlib/source/lux/language/compiler/extension/analysis/host.jvm.lux b/stdlib/source/lux/language/compiler/extension/analysis/host.jvm.lux index e13b32c08..d25be6e40 100644 --- a/stdlib/source/lux/language/compiler/extension/analysis/host.jvm.lux +++ b/stdlib/source/lux/language/compiler/extension/analysis/host.jvm.lux @@ -3,43 +3,50 @@ [control [monad (#+ do)] ["p" parser] - ["ex" exception (#+ exception:)]] + ["ex" exception (#+ exception:)] + pipe] [data ["e" error] [maybe] [product] - [bool ("bool/" Equivalence<Bool>)] [text ("text/" Equivalence<Text>) - format - ["l" lexer]] + format] [collection [list ("list/" Fold<List> Functor<List> Monoid<List>)] [array] - ["dict" dictionary (#+ Dictionary)]]] - [macro ("macro/" Monad<Meta>) - [code] + [dictionary (#+ Dictionary)]]] + ["." macro ["s" syntax]] - ["." language + [language ["." type - ["tc" check]]] + [check]]] [host]] - ["/" //common] - [//// - [".L" analysis (#+ Analysis) - [".A" type] - [".A" inference]]] - [///] + [// + [common] + ["/." // + [bundle] + ["//." // ("operation/" Monad<Operation>) + [analysis (#+ Analysis Operation Handler Bundle) + [".A" type] + [".A" inference]]]]] ) +(type: Method-Signature + {#method Type + #exceptions (List Type)}) + (host.import: #long java/lang/reflect/Type (getTypeName [] String)) -(def: jvm-type-name - (-> java/lang/reflect/Type Text) - (java/lang/reflect/Type::getTypeName [])) +(do-template [<name>] + [(exception: #export (<name> {jvm-type java/lang/reflect/Type}) + (ex.report ["JVM Type" (java/lang/reflect/Type::getTypeName [] jvm-type)]))] -(exception: #export (jvm-type-is-not-a-class {jvm-type java/lang/reflect/Type}) - (jvm-type-name jvm-type)) + [jvm-type-is-not-a-class] + [cannot-convert-to-a-class] + [cannot-convert-to-a-parameter] + [cannot-convert-to-a-lux-type] + ) (do-template [<name>] [(exception: #export (<name> {type Type}) @@ -77,20 +84,19 @@ [cannot-possibly-be-an-instance] - [cannot-convert-to-a-class] - [cannot-convert-to-a-parameter] - [cannot-convert-to-a-lux-type] [unknown-type-var] [type-parameter-mismatch] [cannot-correspond-type-with-a-class] ) (do-template [<name>] - [(exception: #export (<name> {class Text} {method Text} {hints (List [Type (List Type)])}) + [(exception: #export (<name> {class Text} + {method Text} + {hints (List Method-Signature)}) (ex.report ["Class" class] ["Method" method] ["Hints" (|> hints - (list/map (|>> %type (format "\n\t"))) + (list/map (|>> product.left %type (format "\n\t"))) (text.join-with ""))]))] [no-candidates] @@ -122,83 +128,83 @@ [char "char"] ) -(def: conversion-procs - /.Bundle - (<| (/.prefix "convert") - (|> (dict.new text.Hash<Text>) - (/.install "double-to-float" (/.unary Double Float)) - (/.install "double-to-int" (/.unary Double Integer)) - (/.install "double-to-long" (/.unary Double Long)) - (/.install "float-to-double" (/.unary Float Double)) - (/.install "float-to-int" (/.unary Float Integer)) - (/.install "float-to-long" (/.unary Float Long)) - (/.install "int-to-byte" (/.unary Integer Byte)) - (/.install "int-to-char" (/.unary Integer Character)) - (/.install "int-to-double" (/.unary Integer Double)) - (/.install "int-to-float" (/.unary Integer Float)) - (/.install "int-to-long" (/.unary Integer Long)) - (/.install "int-to-short" (/.unary Integer Short)) - (/.install "long-to-double" (/.unary Long Double)) - (/.install "long-to-float" (/.unary Long Float)) - (/.install "long-to-int" (/.unary Long Integer)) - (/.install "long-to-short" (/.unary Long Short)) - (/.install "long-to-byte" (/.unary Long Byte)) - (/.install "char-to-byte" (/.unary Character Byte)) - (/.install "char-to-short" (/.unary Character Short)) - (/.install "char-to-int" (/.unary Character Integer)) - (/.install "char-to-long" (/.unary Character Long)) - (/.install "byte-to-long" (/.unary Byte Long)) - (/.install "short-to-long" (/.unary Short Long)) +(def: bundle::conversion + Bundle + (<| (bundle.prefix "convert") + (|> bundle.empty + (bundle.install "double-to-float" (common.unary Double Float)) + (bundle.install "double-to-int" (common.unary Double Integer)) + (bundle.install "double-to-long" (common.unary Double Long)) + (bundle.install "float-to-double" (common.unary Float Double)) + (bundle.install "float-to-int" (common.unary Float Integer)) + (bundle.install "float-to-long" (common.unary Float Long)) + (bundle.install "int-to-byte" (common.unary Integer Byte)) + (bundle.install "int-to-char" (common.unary Integer Character)) + (bundle.install "int-to-double" (common.unary Integer Double)) + (bundle.install "int-to-float" (common.unary Integer Float)) + (bundle.install "int-to-long" (common.unary Integer Long)) + (bundle.install "int-to-short" (common.unary Integer Short)) + (bundle.install "long-to-double" (common.unary Long Double)) + (bundle.install "long-to-float" (common.unary Long Float)) + (bundle.install "long-to-int" (common.unary Long Integer)) + (bundle.install "long-to-short" (common.unary Long Short)) + (bundle.install "long-to-byte" (common.unary Long Byte)) + (bundle.install "char-to-byte" (common.unary Character Byte)) + (bundle.install "char-to-short" (common.unary Character Short)) + (bundle.install "char-to-int" (common.unary Character Integer)) + (bundle.install "char-to-long" (common.unary Character Long)) + (bundle.install "byte-to-long" (common.unary Byte Long)) + (bundle.install "short-to-long" (common.unary Short Long)) ))) (do-template [<name> <prefix> <type>] [(def: <name> - /.Bundle - (<| (/.prefix <prefix>) - (|> (dict.new text.Hash<Text>) - (/.install "+" (/.binary <type> <type> <type>)) - (/.install "-" (/.binary <type> <type> <type>)) - (/.install "*" (/.binary <type> <type> <type>)) - (/.install "/" (/.binary <type> <type> <type>)) - (/.install "%" (/.binary <type> <type> <type>)) - (/.install "=" (/.binary <type> <type> Boolean)) - (/.install "<" (/.binary <type> <type> Boolean)) - (/.install "and" (/.binary <type> <type> <type>)) - (/.install "or" (/.binary <type> <type> <type>)) - (/.install "xor" (/.binary <type> <type> <type>)) - (/.install "shl" (/.binary <type> Integer <type>)) - (/.install "shr" (/.binary <type> Integer <type>)) - (/.install "ushr" (/.binary <type> Integer <type>)) + Bundle + (<| (bundle.prefix <prefix>) + (|> bundle.empty + (bundle.install "+" (common.binary <type> <type> <type>)) + (bundle.install "-" (common.binary <type> <type> <type>)) + (bundle.install "*" (common.binary <type> <type> <type>)) + (bundle.install "/" (common.binary <type> <type> <type>)) + (bundle.install "%" (common.binary <type> <type> <type>)) + (bundle.install "=" (common.binary <type> <type> Boolean)) + (bundle.install "<" (common.binary <type> <type> Boolean)) + (bundle.install "and" (common.binary <type> <type> <type>)) + (bundle.install "or" (common.binary <type> <type> <type>)) + (bundle.install "xor" (common.binary <type> <type> <type>)) + (bundle.install "shl" (common.binary <type> Integer <type>)) + (bundle.install "shr" (common.binary <type> Integer <type>)) + (bundle.install "ushr" (common.binary <type> Integer <type>)) )))] - [int-procs "int" Integer] - [long-procs "long" Long] + [bundle::int "int" Integer] + [bundle::long "long" Long] ) (do-template [<name> <prefix> <type>] [(def: <name> - /.Bundle - (<| (/.prefix <prefix>) - (|> (dict.new text.Hash<Text>) - (/.install "+" (/.binary <type> <type> <type>)) - (/.install "-" (/.binary <type> <type> <type>)) - (/.install "*" (/.binary <type> <type> <type>)) - (/.install "/" (/.binary <type> <type> <type>)) - (/.install "%" (/.binary <type> <type> <type>)) - (/.install "=" (/.binary <type> <type> Boolean)) - (/.install "<" (/.binary <type> <type> Boolean)) + Bundle + (<| (bundle.prefix <prefix>) + (|> bundle.empty + (bundle.install "+" (common.binary <type> <type> <type>)) + (bundle.install "-" (common.binary <type> <type> <type>)) + (bundle.install "*" (common.binary <type> <type> <type>)) + (bundle.install "/" (common.binary <type> <type> <type>)) + (bundle.install "%" (common.binary <type> <type> <type>)) + (bundle.install "=" (common.binary <type> <type> Boolean)) + (bundle.install "<" (common.binary <type> <type> Boolean)) )))] - [float-procs "float" Float] - [double-procs "double" Double] + [bundle::float "float" Float] + [bundle::double "double" Double] ) -(def: char-procs - /.Bundle - (<| (/.prefix "char") - (|> (dict.new text.Hash<Text>) - (/.install "=" (/.binary Character Character Boolean)) - (/.install "<" (/.binary Character Character Boolean)) +(def: bundle::char + Bundle + (<| (bundle.prefix "char") + (|> bundle.empty + (bundle.install "=" (common.binary Character Character Boolean)) + (bundle.install "<" (common.binary Character Character Boolean)) ))) (def: #export boxes @@ -211,33 +217,33 @@ ["float" "java.lang.Float"] ["double" "java.lang.Double"] ["char" "java.lang.Character"]) - (dict.from-list text.Hash<Text>))) + (dictionary.from-list text.Hash<Text>))) -(def: (array//length proc) - (-> Text ///.Analysis) - (function (_ analyse eval args) +(def: array::length + Handler + (function (_ extension-name analyse args) (case args (^ (list arrayC)) - (do macro.Monad<Meta> + (do ////.Monad<Operation> [_ (typeA.infer Nat) - [var-id varT] (typeA.with-env tc.var) + [var-id varT] (typeA.with-env check.var) arrayA (typeA.with-type (type (Array varT)) (analyse arrayC))] - (wrap (#analysisL.Extension proc (list arrayA)))) + (wrap (#analysis.Extension extension-name (list arrayA)))) _ - (language.throw /.incorrect-extension-arity [proc +1 (list.size args)])))) + (////.throw bundle.incorrect-arity [extension-name +1 (list.size args)])))) -(def: (array//new proc) - (-> Text ///.Analysis) - (function (_ analyse eval args) +(def: array::new + Handler + (function (_ extension-name analyse args) (case args (^ (list lengthC)) - (do macro.Monad<Meta> + (do ////.Monad<Operation> [lengthA (typeA.with-type Nat (analyse lengthC)) - expectedT macro.expected-type - [level elem-class] (: (Meta [Nat Text]) + expectedT (///.lift macro.expected-type) + [level elem-class] (: (Operation [Nat Text]) (loop [analysisT expectedT level +0] (case analysisT @@ -247,7 +253,7 @@ (recur outputT level) #.None - (language.throw non-array expectedT)) + (////.throw non-array expectedT)) (^ (#.Primitive "#Array" (list elemT))) (recur elemT (inc level)) @@ -256,28 +262,28 @@ (wrap [level class]) _ - (language.throw non-array expectedT)))) + (////.throw non-array expectedT)))) _ (if (n/> +0 level) (wrap []) - (language.throw non-array expectedT))] - (wrap (#analysisL.Extension proc (list (analysisL.nat (dec level)) - (analysisL.text elem-class) - lengthA)))) + (////.throw non-array expectedT))] + (wrap (#analysis.Extension extension-name (list (analysis.nat (dec level)) + (analysis.text elem-class) + lengthA)))) _ - (language.throw /.incorrect-extension-arity [proc +1 (list.size args)])))) + (////.throw bundle.incorrect-arity [extension-name +1 (list.size args)])))) (def: (check-jvm objectT) - (-> Type (Meta Text)) + (-> Type (Operation Text)) (case objectT (#.Primitive name _) - (macro/wrap name) + (operation/wrap name) (#.Named name unnamed) (check-jvm unnamed) (#.Var id) - (macro/wrap "java.lang.Object") + (operation/wrap "java.lang.Object") (^template [<tag>] (<tag> env unquantified) @@ -291,130 +297,130 @@ (check-jvm outputT) #.None - (language.throw non-object objectT)) + (////.throw non-object objectT)) _ - (language.throw non-object objectT))) + (////.throw non-object objectT))) (def: (check-object objectT) - (-> Type (Meta Text)) - (do macro.Monad<Meta> + (-> Type (Operation Text)) + (do ////.Monad<Operation> [name (check-jvm objectT)] - (if (dict.contains? name boxes) - (language.throw primitives-are-not-objects name) - (macro/wrap name)))) + (if (dictionary.contains? name boxes) + (////.throw primitives-are-not-objects name) + (operation/wrap name)))) (def: (box-array-element-type elemT) - (-> Type (Meta [Type Text])) + (-> Type (Operation [Type Text])) (case elemT (#.Primitive name #.Nil) - (let [boxed-name (|> (dict.get name boxes) + (let [boxed-name (|> (dictionary.get name boxes) (maybe.default name))] - (macro/wrap [(#.Primitive boxed-name #.Nil) - boxed-name])) + (operation/wrap [(#.Primitive boxed-name #.Nil) + boxed-name])) (#.Primitive name _) - (if (dict.contains? name boxes) - (language.throw primitives-cannot-have-type-parameters name) - (macro/wrap [elemT name])) + (if (dictionary.contains? name boxes) + (////.throw primitives-cannot-have-type-parameters name) + (operation/wrap [elemT name])) _ - (language.throw invalid-type-for-array-element (%type elemT)))) + (////.throw invalid-type-for-array-element (%type elemT)))) -(def: (array//read proc) - (-> Text ///.Analysis) - (function (_ analyse eval args) +(def: array::read + Handler + (function (_ extension-name analyse args) (case args (^ (list arrayC idxC)) - (do macro.Monad<Meta> - [[var-id varT] (typeA.with-env tc.var) + (do ////.Monad<Operation> + [[var-id varT] (typeA.with-env check.var) _ (typeA.infer varT) arrayA (typeA.with-type (type (Array varT)) (analyse arrayC)) ?elemT (typeA.with-env - (tc.read var-id)) + (check.read var-id)) [elemT elem-class] (box-array-element-type (maybe.default varT ?elemT)) idxA (typeA.with-type Nat (analyse idxC))] - (wrap (#analysisL.Extension proc (list (analysisL.text elem-class) idxA arrayA)))) + (wrap (#analysis.Extension extension-name (list (analysis.text elem-class) idxA arrayA)))) _ - (language.throw /.incorrect-extension-arity [proc +2 (list.size args)])))) + (////.throw bundle.incorrect-arity [extension-name +2 (list.size args)])))) -(def: (array//write proc) - (-> Text ///.Analysis) - (function (_ analyse eval args) +(def: array::write + Handler + (function (_ extension-name analyse args) (case args (^ (list arrayC idxC valueC)) - (do macro.Monad<Meta> - [[var-id varT] (typeA.with-env tc.var) + (do ////.Monad<Operation> + [[var-id varT] (typeA.with-env check.var) _ (typeA.infer (type (Array varT))) arrayA (typeA.with-type (type (Array varT)) (analyse arrayC)) ?elemT (typeA.with-env - (tc.read var-id)) + (check.read var-id)) [valueT elem-class] (box-array-element-type (maybe.default varT ?elemT)) idxA (typeA.with-type Nat (analyse idxC)) valueA (typeA.with-type valueT (analyse valueC))] - (wrap (#analysisL.Extension proc (list (analysisL.text elem-class) idxA valueA arrayA)))) + (wrap (#analysis.Extension extension-name (list (analysis.text elem-class) idxA valueA arrayA)))) _ - (language.throw /.incorrect-extension-arity [proc +3 (list.size args)])))) - -(def: array-procs - /.Bundle - (<| (/.prefix "array") - (|> (dict.new text.Hash<Text>) - (/.install "length" array//length) - (/.install "new" array//new) - (/.install "read" array//read) - (/.install "write" array//write) + (////.throw bundle.incorrect-arity [extension-name +3 (list.size args)])))) + +(def: bundle::array + Bundle + (<| (bundle.prefix "array") + (|> bundle.empty + (bundle.install "length" array::length) + (bundle.install "new" array::new) + (bundle.install "read" array::read) + (bundle.install "write" array::write) ))) -(def: (object//null proc) - (-> Text ///.Analysis) - (function (_ analyse eval args) +(def: object::null + Handler + (function (_ extension-name analyse args) (case args (^ (list)) - (do macro.Monad<Meta> - [expectedT macro.expected-type + (do ////.Monad<Operation> + [expectedT (///.lift macro.expected-type) _ (check-object expectedT)] - (wrap (#analysisL.Extension proc (list)))) + (wrap (#analysis.Extension extension-name (list)))) _ - (language.throw /.incorrect-extension-arity [proc +0 (list.size args)])))) + (////.throw bundle.incorrect-arity [extension-name +0 (list.size args)])))) -(def: (object//null? proc) - (-> Text ///.Analysis) - (function (_ analyse eval args) +(def: object::null? + Handler + (function (_ extension-name analyse args) (case args (^ (list objectC)) - (do macro.Monad<Meta> + (do ////.Monad<Operation> [_ (typeA.infer Bool) [objectT objectA] (typeA.with-inference (analyse objectC)) _ (check-object objectT)] - (wrap (#analysisL.Extension proc (list objectA)))) + (wrap (#analysis.Extension extension-name (list objectA)))) _ - (language.throw /.incorrect-extension-arity [proc +1 (list.size args)])))) + (////.throw bundle.incorrect-arity [extension-name +1 (list.size args)])))) -(def: (object//synchronized proc) - (-> Text ///.Analysis) - (function (_ analyse eval args) +(def: object::synchronized + Handler + (function (_ extension-name analyse args) (case args (^ (list monitorC exprC)) - (do macro.Monad<Meta> + (do ////.Monad<Operation> [[monitorT monitorA] (typeA.with-inference (analyse monitorC)) _ (check-object monitorT) exprA (analyse exprC)] - (wrap (#analysisL.Extension proc (list monitorA exprA)))) + (wrap (#analysis.Extension extension-name (list monitorA exprA)))) _ - (language.throw /.incorrect-extension-arity [proc +2 (list.size args)])))) + (////.throw bundle.incorrect-arity [extension-name +2 (list.size args)])))) (host.import: java/lang/Object (equals [Object] boolean)) @@ -476,110 +482,110 @@ (getDeclaredMethods [] (Array Method))) (def: (load-class name) - (-> Text (Meta (Class Object))) - (do macro.Monad<Meta> + (-> Text (Operation (Class Object))) + (do ////.Monad<Operation> [] (case (Class::forName [name]) (#e.Success [class]) (wrap class) (#e.Error error) - (language.throw unknown-class name)))) + (////.throw unknown-class name)))) (def: (sub-class? super sub) - (-> Text Text (Meta Bool)) - (do macro.Monad<Meta> + (-> Text Text (Operation Bool)) + (do ////.Monad<Operation> [super (load-class super) sub (load-class sub)] (wrap (Class::isAssignableFrom [sub] super)))) -(def: (object//throw proc) - (-> Text ///.Analysis) - (function (_ analyse eval args) +(def: object::throw + Handler + (function (_ extension-name analyse args) (case args (^ (list exceptionC)) - (do macro.Monad<Meta> + (do ////.Monad<Operation> [_ (typeA.infer Nothing) [exceptionT exceptionA] (typeA.with-inference (analyse exceptionC)) exception-class (check-object exceptionT) ? (sub-class? "java.lang.Throwable" exception-class) - _ (: (Meta Any) + _ (: (Operation Any) (if ? (wrap []) - (language.throw non-throwable exception-class)))] - (wrap (#analysisL.Extension proc (list exceptionA)))) + (////.throw non-throwable exception-class)))] + (wrap (#analysis.Extension extension-name (list exceptionA)))) _ - (language.throw /.incorrect-extension-arity [proc +1 (list.size args)])))) + (////.throw bundle.incorrect-arity [extension-name +1 (list.size args)])))) -(def: (object//class proc) - (-> Text ///.Analysis) - (function (_ analyse eval args) +(def: object::class + Handler + (function (_ extension-name analyse args) (case args (^ (list classC)) (case classC [_ (#.Text class)] - (do macro.Monad<Meta> + (do ////.Monad<Operation> [_ (typeA.infer (#.Primitive "java.lang.Class" (list (#.Primitive class (list))))) _ (load-class class)] - (wrap (#analysisL.Extension proc (list (analysisL.text class))))) + (wrap (#analysis.Extension extension-name (list (analysis.text class))))) _ - (language.throw /.invalid-syntax [proc args])) + (////.throw bundle.invalid-syntax extension-name)) _ - (language.throw /.incorrect-extension-arity [proc +1 (list.size args)])))) + (////.throw bundle.incorrect-arity [extension-name +1 (list.size args)])))) -(def: (object//instance? proc) - (-> Text ///.Analysis) - (function (_ analyse eval args) +(def: object::instance? + Handler + (function (_ extension-name analyse args) (case args (^ (list classC objectC)) (case classC [_ (#.Text class)] - (do macro.Monad<Meta> + (do ////.Monad<Operation> [_ (typeA.infer Bool) [objectT objectA] (typeA.with-inference (analyse objectC)) object-class (check-object objectT) ? (sub-class? class object-class)] (if ? - (wrap (#analysisL.Extension proc (list (analysisL.text class)))) - (language.throw cannot-possibly-be-an-instance (format object-class " !<= " class)))) + (wrap (#analysis.Extension extension-name (list (analysis.text class)))) + (////.throw cannot-possibly-be-an-instance (format object-class " !<= " class)))) _ - (language.throw /.invalid-syntax [proc args])) + (////.throw bundle.invalid-syntax extension-name)) _ - (language.throw /.incorrect-extension-arity [proc +2 (list.size args)])))) + (////.throw bundle.incorrect-arity [extension-name +2 (list.size args)])))) -(def: (java-type-to-class type) - (-> java/lang/reflect/Type (Meta Text)) - (cond (host.instance? Class type) - (macro/wrap (Class::getName [] (:coerce Class type))) +(def: (java-type-to-class jvm-type) + (-> java/lang/reflect/Type (Operation Text)) + (cond (host.instance? Class jvm-type) + (operation/wrap (Class::getName [] (:coerce Class jvm-type))) - (host.instance? ParameterizedType type) - (java-type-to-class (ParameterizedType::getRawType [] (:coerce ParameterizedType type))) + (host.instance? ParameterizedType jvm-type) + (java-type-to-class (ParameterizedType::getRawType [] (:coerce ParameterizedType jvm-type))) ## else - (language.throw cannot-convert-to-a-class (jvm-type-name type)))) + (////.throw cannot-convert-to-a-class jvm-type))) (type: Mappings (Dictionary Text Type)) -(def: fresh-mappings Mappings (dict.new text.Hash<Text>)) +(def: fresh-mappings Mappings (dictionary.new text.Hash<Text>)) (def: (java-type-to-lux-type mappings java-type) - (-> Mappings java/lang/reflect/Type (Meta Type)) + (-> Mappings java/lang/reflect/Type (Operation Type)) (cond (host.instance? TypeVariable java-type) (let [var-name (TypeVariable::getName [] (:coerce TypeVariable java-type))] - (case (dict.get var-name mappings) + (case (dictionary.get var-name mappings) (#.Some var-type) - (macro/wrap var-type) + (operation/wrap var-type) #.None - (language.throw unknown-type-var var-name))) + (////.throw unknown-type-var var-name))) (host.instance? WildcardType java-type) (let [java-type (:coerce WildcardType java-type)] @@ -589,47 +595,47 @@ (java-type-to-lux-type mappings bound) _ - (macro/wrap Any))) + (operation/wrap Any))) (host.instance? Class java-type) (let [java-type (:coerce (Class Object) java-type) class-name (Class::getName [] java-type)] - (macro/wrap (case (array.size (Class::getTypeParameters [] java-type)) - +0 - (#.Primitive class-name (list)) - - arity - (|> (list.n/range +0 (dec arity)) - list.reverse - (list/map (|>> (n/* +2) inc #.Parameter)) - (#.Primitive class-name) - (type.univ-q arity))))) + (operation/wrap (case (array.size (Class::getTypeParameters [] java-type)) + +0 + (#.Primitive class-name (list)) + + arity + (|> (list.n/range +0 (dec arity)) + list.reverse + (list/map (|>> (n/* +2) inc #.Parameter)) + (#.Primitive class-name) + (type.univ-q arity))))) (host.instance? ParameterizedType java-type) (let [java-type (:coerce ParameterizedType java-type) raw (ParameterizedType::getRawType [] java-type)] (if (host.instance? Class raw) - (do macro.Monad<Meta> + (do ////.Monad<Operation> [paramsT (|> java-type (ParameterizedType::getActualTypeArguments []) array.to-list (monad.map @ (java-type-to-lux-type mappings)))] - (macro/wrap (#.Primitive (Class::getName [] (:coerce (Class Object) raw)) - paramsT))) - (language.throw jvm-type-is-not-a-class raw))) + (operation/wrap (#.Primitive (Class::getName [] (:coerce (Class Object) raw)) + paramsT))) + (////.throw jvm-type-is-not-a-class raw))) (host.instance? GenericArrayType java-type) - (do macro.Monad<Meta> + (do ////.Monad<Operation> [innerT (|> (:coerce GenericArrayType java-type) (GenericArrayType::getGenericComponentType []) (java-type-to-lux-type mappings))] (wrap (#.Primitive "#Array" (list innerT)))) ## else - (language.throw cannot-convert-to-a-lux-type (jvm-type-name java-type)))) + (////.throw cannot-convert-to-a-lux-type java-type))) (def: (correspond-type-params class type) - (-> (Class Object) Type (Meta Mappings)) + (-> (Class Object) Type (Operation Mappings)) (case type (#.Primitive name params) (let [class-name (Class::getName [] class) @@ -637,38 +643,38 @@ num-class-params (list.size class-params) num-type-params (list.size params)] (cond (not (text/= class-name name)) - (language.throw cannot-correspond-type-with-a-class - (format "Class = " class-name "\n" - "Type = " (%type type))) + (////.throw cannot-correspond-type-with-a-class + (format "Class = " class-name "\n" + "Type = " (%type type))) (not (n/= num-class-params num-type-params)) - (language.throw type-parameter-mismatch - (format "Expected: " (%i (.int num-class-params)) "\n" - " Actual: " (%i (.int num-type-params)) "\n" - " Class: " class-name "\n" - " Type: " (%type type))) + (////.throw type-parameter-mismatch + (format "Expected: " (%i (.int num-class-params)) "\n" + " Actual: " (%i (.int num-type-params)) "\n" + " Class: " class-name "\n" + " Type: " (%type type))) ## else - (macro/wrap (|> params - (list.zip2 (list/map (TypeVariable::getName []) class-params)) - (dict.from-list text.Hash<Text>))) + (operation/wrap (|> params + (list.zip2 (list/map (TypeVariable::getName []) class-params)) + (dictionary.from-list text.Hash<Text>))) )) _ - (language.throw non-jvm-type type))) + (////.throw non-jvm-type type))) -(def: (object//cast proc) - (-> Text ///.Analysis) - (function (_ analyse eval args) +(def: object::cast + Handler + (function (_ extension-name analyse args) (case args (^ (list valueC)) - (do macro.Monad<Meta> - [toT macro.expected-type + (do ////.Monad<Operation> + [toT (///.lift macro.expected-type) to-name (check-jvm toT) [valueT valueA] (typeA.with-inference (analyse valueC)) from-name (check-jvm valueT) - can-cast? (: (Meta Bool) + can-cast? (: (Operation Bool) (case [from-name to-name] (^template [<primitive> <object>] (^or [<primitive> <object>] @@ -687,10 +693,10 @@ _ (do @ - [_ (language.assert primitives-are-not-objects from-name - (not (dict.contains? from-name boxes))) - _ (language.assert primitives-are-not-objects to-name - (not (dict.contains? to-name boxes))) + [_ (////.assert primitives-are-not-objects from-name + (not (dictionary.contains? from-name boxes))) + _ (////.assert primitives-are-not-objects to-name + (not (dictionary.contains? to-name boxes))) to-class (load-class to-name)] (loop [[current-name currentT] [from-name valueT]] (if (text/= to-name current-name) @@ -699,10 +705,10 @@ (wrap true)) (do @ [current-class (load-class current-name) - _ (language.assert cannot-cast (format "From class/primitive: " current-name "\n" - " To class/primitive: " to-name "\n" - " For value: " (%code valueC) "\n") - (Class::isAssignableFrom [current-class] to-class)) + _ (////.assert cannot-cast (format "From class/primitive: " current-name "\n" + " To class/primitive: " to-name "\n" + " For value: " (%code valueC) "\n") + (Class::isAssignableFrom [current-class] to-class)) candiate-parents (monad.map @ (function (_ java-type) (do @ @@ -721,54 +727,54 @@ (recur [next-name nextT])) #.Nil - (language.throw cannot-cast (format "From class/primitive: " from-name "\n" - " To class/primitive: " to-name "\n" - " For value: " (%code valueC) "\n"))) + (////.throw cannot-cast (format "From class/primitive: " from-name "\n" + " To class/primitive: " to-name "\n" + " For value: " (%code valueC) "\n"))) ))))))] (if can-cast? - (wrap (#analysisL.Extension proc (list (analysisL.text from-name) - (analysisL.text to-name) - valueA))) - (language.throw cannot-cast (format "From class/primitive: " from-name "\n" - " To class/primitive: " to-name "\n" - " For value: " (%code valueC) "\n")))) + (wrap (#analysis.Extension extension-name (list (analysis.text from-name) + (analysis.text to-name) + valueA))) + (////.throw cannot-cast (format "From class/primitive: " from-name "\n" + " To class/primitive: " to-name "\n" + " For value: " (%code valueC) "\n")))) _ - (language.throw /.invalid-syntax [proc args])))) - -(def: object-procs - /.Bundle - (<| (/.prefix "object") - (|> (dict.new text.Hash<Text>) - (/.install "null" object//null) - (/.install "null?" object//null?) - (/.install "synchronized" object//synchronized) - (/.install "throw" object//throw) - (/.install "class" object//class) - (/.install "instance?" object//instance?) - (/.install "cast" object//cast) + (////.throw bundle.invalid-syntax extension-name)))) + +(def: bundle::object + Bundle + (<| (bundle.prefix "object") + (|> bundle.empty + (bundle.install "null" object::null) + (bundle.install "null?" object::null?) + (bundle.install "synchronized" object::synchronized) + (bundle.install "throw" object::throw) + (bundle.install "class" object::class) + (bundle.install "instance?" object::instance?) + (bundle.install "cast" object::cast) ))) (def: (find-field class-name field-name) - (-> Text Text (Meta [(Class Object) Field])) - (do macro.Monad<Meta> + (-> Text Text (Operation [(Class Object) Field])) + (do ////.Monad<Operation> [class (load-class class-name)] (case (Class::getDeclaredField [field-name] class) (#e.Success field) (let [owner (Field::getDeclaringClass [] field)] (if (is? owner class) (wrap [class field]) - (language.throw mistaken-field-owner - (format " Field: " field-name "\n" - " Owner Class: " (Class::getName [] owner) "\n" - "Target Class: " class-name "\n")))) + (////.throw mistaken-field-owner + (format " Field: " field-name "\n" + " Owner Class: " (Class::getName [] owner) "\n" + "Target Class: " class-name "\n")))) (#e.Error _) - (language.throw unknown-field (format class-name "#" field-name))))) + (////.throw unknown-field (format class-name "#" field-name))))) (def: (static-field class-name field-name) - (-> Text Text (Meta [Type Bool])) - (do macro.Monad<Meta> + (-> Text Text (Operation [Type Bool])) + (do ////.Monad<Operation> [[class fieldJ] (find-field class-name field-name) #let [modifiers (Field::getModifiers [] fieldJ)]] (if (Modifier::isStatic [modifiers]) @@ -776,11 +782,11 @@ (do @ [fieldT (java-type-to-lux-type fresh-mappings fieldJT)] (wrap [fieldT (Modifier::isFinal [modifiers])]))) - (language.throw not-a-static-field (format class-name "#" field-name))))) + (////.throw not-a-static-field (format class-name "#" field-name))))) (def: (virtual-field class-name field-name objectT) - (-> Text Text Type (Meta [Type Bool])) - (do macro.Monad<Meta> + (-> Text Text Type (Operation [Type Bool])) + (do ////.Monad<Operation> [[class fieldJ] (find-field class-name field-name) #let [modifiers (Field::getModifiers [] fieldJ)]] (if (not (Modifier::isStatic [modifiers])) @@ -790,130 +796,130 @@ (Class::getTypeParameters []) array.to-list (list/map (TypeVariable::getName [])))] - mappings (: (Meta Mappings) + mappings (: (Operation Mappings) (case objectT (#.Primitive _class-name _class-params) (do @ [#let [num-params (list.size _class-params) num-vars (list.size var-names)] - _ (language.assert type-parameter-mismatch - (format "Expected: " (%i (.int num-params)) "\n" - " Actual: " (%i (.int num-vars)) "\n" - " Class: " _class-name "\n" - " Type: " (%type objectT)) - (n/= num-params num-vars))] + _ (////.assert type-parameter-mismatch + (format "Expected: " (%i (.int num-params)) "\n" + " Actual: " (%i (.int num-vars)) "\n" + " Class: " _class-name "\n" + " Type: " (%type objectT)) + (n/= num-params num-vars))] (wrap (|> (list.zip2 var-names _class-params) - (dict.from-list text.Hash<Text>)))) + (dictionary.from-list text.Hash<Text>)))) _ - (language.throw non-object objectT))) + (////.throw non-object objectT))) fieldT (java-type-to-lux-type mappings fieldJT)] (wrap [fieldT (Modifier::isFinal [modifiers])])) - (language.throw not-a-virtual-field (format class-name "#" field-name))))) + (////.throw not-a-virtual-field (format class-name "#" field-name))))) -(def: (static//get proc) - (-> Text ///.Analysis) - (function (_ analyse eval args) +(def: static::get + Handler + (function (_ extension-name analyse args) (case args (^ (list classC fieldC)) (case [classC fieldC] [[_ (#.Text class)] [_ (#.Text field)]] - (do macro.Monad<Meta> + (do ////.Monad<Operation> [[fieldT final?] (static-field class field)] - (wrap (#analysisL.Extension proc (list (analysisL.text class) (analysisL.text field))))) + (wrap (#analysis.Extension extension-name (list (analysis.text class) (analysis.text field))))) _ - (language.throw /.invalid-syntax [proc args])) + (////.throw bundle.invalid-syntax extension-name)) _ - (language.throw /.incorrect-extension-arity [proc +2 (list.size args)])))) + (////.throw bundle.incorrect-arity [extension-name +2 (list.size args)])))) -(def: (static//put proc) - (-> Text ///.Analysis) - (function (_ analyse eval args) +(def: static::put + Handler + (function (_ extension-name analyse args) (case args (^ (list classC fieldC valueC)) (case [classC fieldC] [[_ (#.Text class)] [_ (#.Text field)]] - (do macro.Monad<Meta> + (do ////.Monad<Operation> [_ (typeA.infer Any) [fieldT final?] (static-field class field) - _ (language.assert cannot-set-a-final-field (format class "#" field) - (not final?)) + _ (////.assert cannot-set-a-final-field (format class "#" field) + (not final?)) valueA (typeA.with-type fieldT (analyse valueC))] - (wrap (#analysisL.Extension proc (list (analysisL.text class) (analysisL.text field) valueA)))) + (wrap (#analysis.Extension extension-name (list (analysis.text class) (analysis.text field) valueA)))) _ - (language.throw /.invalid-syntax [proc args])) + (////.throw bundle.invalid-syntax extension-name)) _ - (language.throw /.incorrect-extension-arity [proc +3 (list.size args)])))) + (////.throw bundle.incorrect-arity [extension-name +3 (list.size args)])))) -(def: (virtual//get proc) - (-> Text ///.Analysis) - (function (_ analyse eval args) +(def: virtual::get + Handler + (function (_ extension-name analyse args) (case args (^ (list classC fieldC objectC)) (case [classC fieldC] [[_ (#.Text class)] [_ (#.Text field)]] - (do macro.Monad<Meta> + (do ////.Monad<Operation> [[objectT objectA] (typeA.with-inference (analyse objectC)) [fieldT final?] (virtual-field class field objectT)] - (wrap (#analysisL.Extension proc (list (analysisL.text class) (analysisL.text field) objectA)))) + (wrap (#analysis.Extension extension-name (list (analysis.text class) (analysis.text field) objectA)))) _ - (language.throw /.invalid-syntax [proc args])) + (////.throw bundle.invalid-syntax extension-name)) _ - (language.throw /.incorrect-extension-arity [proc +3 (list.size args)])))) + (////.throw bundle.incorrect-arity [extension-name +3 (list.size args)])))) -(def: (virtual//put proc) - (-> Text ///.Analysis) - (function (_ analyse eval args) +(def: virtual::put + Handler + (function (_ extension-name analyse args) (case args (^ (list classC fieldC valueC objectC)) (case [classC fieldC] [[_ (#.Text class)] [_ (#.Text field)]] - (do macro.Monad<Meta> + (do ////.Monad<Operation> [[objectT objectA] (typeA.with-inference (analyse objectC)) _ (typeA.infer objectT) [fieldT final?] (virtual-field class field objectT) - _ (language.assert cannot-set-a-final-field (format class "#" field) - (not final?)) + _ (////.assert cannot-set-a-final-field (format class "#" field) + (not final?)) valueA (typeA.with-type fieldT (analyse valueC))] - (wrap (#analysisL.Extension proc (list (analysisL.text class) (analysisL.text field) valueA objectA)))) + (wrap (#analysis.Extension extension-name (list (analysis.text class) (analysis.text field) valueA objectA)))) _ - (language.throw /.invalid-syntax [proc args])) + (////.throw bundle.invalid-syntax extension-name)) _ - (language.throw /.incorrect-extension-arity [proc +4 (list.size args)])))) + (////.throw bundle.incorrect-arity [extension-name +4 (list.size args)])))) (def: (java-type-to-parameter type) - (-> java/lang/reflect/Type (Meta Text)) + (-> java/lang/reflect/Type (Operation Text)) (cond (host.instance? Class type) - (macro/wrap (Class::getName [] (:coerce Class type))) + (operation/wrap (Class::getName [] (:coerce Class type))) (host.instance? ParameterizedType type) (java-type-to-parameter (ParameterizedType::getRawType [] (:coerce ParameterizedType type))) (or (host.instance? TypeVariable type) (host.instance? WildcardType type)) - (macro/wrap "java.lang.Object") + (operation/wrap "java.lang.Object") (host.instance? GenericArrayType type) - (do macro.Monad<Meta> + (do ////.Monad<Operation> [componentP (java-type-to-parameter (GenericArrayType::getGenericComponentType [] (:coerce GenericArrayType type)))] (wrap (format componentP "[]"))) ## else - (language.throw cannot-convert-to-a-parameter (jvm-type-name type)))) + (////.throw cannot-convert-to-a-parameter type))) -(type: Method-style +(type: Method-Style #Static #Abstract #Virtual @@ -921,8 +927,8 @@ #Interface) (def: (check-method class method-name method-style arg-classes method) - (-> (Class Object) Text Method-style (List Text) Method (Meta Bool)) - (do macro.Monad<Meta> + (-> (Class Object) Text Method-Style (List Text) Method (Operation Bool)) + (do ////.Monad<Operation> [parameters (|> (Method::getGenericParameterTypes [] method) array.to-list (monad.map @ java-type-to-parameter)) @@ -950,8 +956,8 @@ (list.zip2 arg-classes parameters)))))) (def: (check-constructor class arg-classes constructor) - (-> (Class Object) (List Text) (Constructor Object) (Meta Bool)) - (do macro.Monad<Meta> + (-> (Class Object) (List Text) (Constructor Object) (Operation Bool)) + (do ////.Monad<Operation> [parameters (|> (Constructor::getGenericParameterTypes [] constructor) array.to-list (monad.map @ java-type-to-parameter))] @@ -974,8 +980,8 @@ (|> (list.n/range offset (|> amount dec (n/+ offset))) (list/map idx-to-parameter)))) -(def: (method-to-type method-style method) - (-> Method-style Method (Meta [Type (List Type)])) +(def: (method-signature method-style method) + (-> Method-Style Method (Operation Method-Signature)) (let [owner (Method::getDeclaringClass [] method) owner-name (Class::getName [] owner) owner-tvars (case method-style @@ -1001,8 +1007,8 @@ (|> (list/compose owner-tvarsT method-tvarsT) list.reverse (list.zip2 all-tvars) - (dict.from-list text.Hash<Text>))))] - (do macro.Monad<Meta> + (dictionary.from-list text.Hash<Text>))))] + (do ////.Monad<Operation> [inputsT (|> (Method::getGenericParameterTypes [] method) array.to-list (monad.map @ (java-type-to-lux-type mappings))) @@ -1021,14 +1027,14 @@ outputT)]] (wrap [methodT exceptionsT])))) -(type: (Evaluation a) - (#Pass a) - (#Hint a) +(type: Evaluation + (#Pass Method-Signature) + (#Hint Method-Signature) #Fail) (do-template [<name> <tag>] [(def: <name> - (All [a] (-> (Evaluation a) (Maybe a))) + (-> Evaluation (Maybe Method-Signature)) (|>> (case> (<tag> output) (#.Some output) @@ -1040,40 +1046,36 @@ ) (def: (method-candidate class-name method-name method-style arg-classes) - (-> Text Text Method-style (List Text) (Meta [Type (List Type)])) - (do macro.Monad<Meta> + (-> Text Text Method-Style (List Text) (Operation Method-Signature)) + (do ////.Monad<Operation> [class (load-class class-name) candidates (|> class (Class::getDeclaredMethods []) array.to-list - (monad.map @ (: (-> Method (Meta (Evaluation Method))) + (monad.map @ (: (-> Method (Operation Evaluation)) (function (_ method) (do @ [passes? (check-method class method-name method-style arg-classes method)] - (wrap (cond passes? - (#Pass method) + (cond passes? + (:: @ map (|>> #Pass) (method-signature method-style method)) - (text/= method-name (Method::getName [] method)) - (#Hint method) + (text/= method-name (Method::getName [] method)) + (:: @ map (|>> #Hint) (method-signature method-style method)) - ## else - #Fail)))))))] + ## else + (wrap #Fail)))))))] (case (list.search-all pass! candidates) #.Nil - (language.throw no-candidates [class-name method-name - (|> candidates - (list.search-all hint!) - (list/map (method-to-type method-style)))]) + (////.throw no-candidates [class-name method-name (list.search-all hint! candidates)]) (#.Cons method #.Nil) - (method-to-type method-style method) + (wrap method) candidates - (language.throw too-many-candidates [class-name method-name - (list/map (method-to-type method-style) candidates)])))) + (////.throw too-many-candidates [class-name method-name candidates])))) -(def: (constructor-to-type constructor) - (-> (Constructor Object) (Meta [Type (List Type)])) +(def: (constructor-signature constructor) + (-> (Constructor Object) (Operation Method-Signature)) (let [owner (Constructor::getDeclaringClass [] constructor) owner-name (Class::getName [] owner) owner-tvars (|> (Class::getTypeParameters [] owner) @@ -1093,8 +1095,8 @@ (|> (list/compose owner-tvarsT constructor-tvarsT) list.reverse (list.zip2 all-tvars) - (dict.from-list text.Hash<Text>))))] - (do macro.Monad<Meta> + (dictionary.from-list text.Hash<Text>))))] + (do ////.Monad<Operation> [inputsT (|> (Constructor::getGenericParameterTypes [] constructor) array.to-list (monad.map @ (java-type-to-lux-type mappings))) @@ -1110,8 +1112,8 @@ (def: constructor-method "<init>") (def: (constructor-candidate class-name arg-classes) - (-> Text (List Text) (Meta [Type (List Type)])) - (do macro.Monad<Meta> + (-> Text (List Text) (Operation Method-Signature)) + (do ////.Monad<Operation> [class (load-class class-name) candidates (|> class (Class::getConstructors []) @@ -1119,52 +1121,50 @@ (monad.map @ (function (_ constructor) (do @ [passes? (check-constructor class arg-classes constructor)] - (wrap [passes? constructor])))))] + (:: @ map + (if passes? (|>> #Pass) (|>> #Hint)) + (constructor-signature constructor))))))] (case (list.search-all pass! candidates) #.Nil - (language.throw no-candidates [class-name ..constructor-method - (|> candidates - (list.search-all hint!) - (list/map constructor-to-type))]) + (////.throw no-candidates [class-name ..constructor-method (list.search-all hint! candidates)]) (#.Cons constructor #.Nil) - (constructor-to-type constructor) + (wrap constructor) candidates - (language.throw too-many-candidates [class-name ..constructor-method - (list/map constructor-to-type candidates)])))) + (////.throw too-many-candidates [class-name ..constructor-method candidates])))) (def: (decorate-inputs typesT inputsA) (-> (List Text) (List Analysis) (List Analysis)) (|> inputsA - (list.zip2 (list/map analysisL.text typesT)) + (list.zip2 (list/map analysis.text typesT)) (list/map (function (_ [type value]) - (analysisL.product-analysis (list type value)))))) + (analysis.product-analysis (list type value)))))) -(def: (invoke//static proc) - (-> Text ///.Analysis) - (function (_ analyse eval args) +(def: invoke::static + Handler + (function (_ extension-name analyse args) (case (: (e.Error [Text Text (List [Text Code])]) (s.run args ($_ p.seq s.text s.text (p.some (s.tuple (p.seq s.text s.any)))))) (#e.Success [class method argsTC]) - (do macro.Monad<Meta> + (do ////.Monad<Operation> [#let [argsT (list/map product.left argsTC)] [methodT exceptionsT] (method-candidate class method #Static argsT) [outputT argsA] (inferenceA.general analyse methodT (list/map product.right argsTC)) outputJC (check-jvm outputT)] - (wrap (#analysisL.Extension proc (list& (analysisL.text class) (analysisL.text method) - (analysisL.text outputJC) (decorate-inputs argsT argsA))))) + (wrap (#analysis.Extension extension-name (list& (analysis.text class) (analysis.text method) + (analysis.text outputJC) (decorate-inputs argsT argsA))))) _ - (language.throw /.invalid-syntax [proc args])))) + (////.throw bundle.invalid-syntax extension-name)))) -(def: (invoke//virtual proc) - (-> Text ///.Analysis) - (function (_ analyse eval args) +(def: invoke::virtual + Handler + (function (_ extension-name analyse args) (case (: (e.Error [Text Text Code (List [Text Code])]) (s.run args ($_ p.seq s.text s.text s.any (p.some (s.tuple (p.seq s.text s.any)))))) (#e.Success [class method objectC argsTC]) - (do macro.Monad<Meta> + (do ////.Monad<Operation> [#let [argsT (list/map product.left argsTC)] [methodT exceptionsT] (method-candidate class method #Virtual argsT) [outputT allA] (inferenceA.general analyse methodT (list& objectC (list/map product.right argsTC))) @@ -1175,98 +1175,98 @@ _ (undefined))] outputJC (check-jvm outputT)] - (wrap (#analysisL.Extension proc (list& (analysisL.text class) (analysisL.text method) - (analysisL.text outputJC) objectA (decorate-inputs argsT argsA))))) + (wrap (#analysis.Extension extension-name (list& (analysis.text class) (analysis.text method) + (analysis.text outputJC) objectA (decorate-inputs argsT argsA))))) _ - (language.throw /.invalid-syntax [proc args])))) + (////.throw bundle.invalid-syntax extension-name)))) -(def: (invoke//special proc) - (-> Text ///.Analysis) - (function (_ analyse eval args) +(def: invoke::special + Handler + (function (_ extension-name analyse args) (case (: (e.Error [(List Code) [Text Text Code (List [Text Code]) Any]]) (p.run args ($_ p.seq s.text s.text s.any (p.some (s.tuple (p.seq s.text s.any))) s.end!))) (#e.Success [_ [class method objectC argsTC _]]) - (do macro.Monad<Meta> + (do ////.Monad<Operation> [#let [argsT (list/map product.left argsTC)] [methodT exceptionsT] (method-candidate class method #Special argsT) [outputT argsA] (inferenceA.general analyse methodT (list& objectC (list/map product.right argsTC))) outputJC (check-jvm outputT)] - (wrap (#analysisL.Extension proc (list& (analysisL.text class) (analysisL.text method) - (analysisL.text outputJC) (decorate-inputs argsT argsA))))) + (wrap (#analysis.Extension extension-name (list& (analysis.text class) (analysis.text method) + (analysis.text outputJC) (decorate-inputs argsT argsA))))) _ - (language.throw /.invalid-syntax [proc args])))) + (////.throw bundle.invalid-syntax extension-name)))) -(def: (invoke//interface proc) - (-> Text ///.Analysis) - (function (_ analyse eval args) +(def: invoke::interface + Handler + (function (_ extension-name analyse args) (case (: (e.Error [Text Text Code (List [Text Code])]) (s.run args ($_ p.seq s.text s.text s.any (p.some (s.tuple (p.seq s.text s.any)))))) (#e.Success [class-name method objectC argsTC]) - (do macro.Monad<Meta> + (do ////.Monad<Operation> [#let [argsT (list/map product.left argsTC)] class (load-class class-name) - _ (language.assert non-interface class-name - (Modifier::isInterface [(Class::getModifiers [] class)])) + _ (////.assert non-interface class-name + (Modifier::isInterface [(Class::getModifiers [] class)])) [methodT exceptionsT] (method-candidate class-name method #Interface argsT) [outputT argsA] (inferenceA.general analyse methodT (list& objectC (list/map product.right argsTC))) outputJC (check-jvm outputT)] - (wrap (#analysisL.Extension proc - (list& (analysisL.text class-name) (analysisL.text method) (analysisL.text outputJC) - (decorate-inputs argsT argsA))))) + (wrap (#analysis.Extension extension-name + (list& (analysis.text class-name) (analysis.text method) (analysis.text outputJC) + (decorate-inputs argsT argsA))))) _ - (language.throw /.invalid-syntax [proc args])))) + (////.throw bundle.invalid-syntax extension-name)))) -(def: (invoke//constructor proc) - (-> Text ///.Analysis) - (function (_ analyse eval args) +(def: invoke::constructor + Handler + (function (_ extension-name analyse args) (case (: (e.Error [Text (List [Text Code])]) (s.run args ($_ p.seq s.text (p.some (s.tuple (p.seq s.text s.any)))))) (#e.Success [class argsTC]) - (do macro.Monad<Meta> + (do ////.Monad<Operation> [#let [argsT (list/map product.left argsTC)] [methodT exceptionsT] (constructor-candidate class argsT) [outputT argsA] (inferenceA.general analyse methodT (list/map product.right argsTC))] - (wrap (#analysisL.Extension proc (list& (analysisL.text class) (decorate-inputs argsT argsA))))) + (wrap (#analysis.Extension extension-name (list& (analysis.text class) (decorate-inputs argsT argsA))))) _ - (language.throw /.invalid-syntax [proc args])))) - -(def: member-procs - /.Bundle - (<| (/.prefix "member") - (|> (dict.new text.Hash<Text>) - (dict.merge (<| (/.prefix "static") - (|> (dict.new text.Hash<Text>) - (/.install "get" static//get) - (/.install "put" static//put)))) - (dict.merge (<| (/.prefix "virtual") - (|> (dict.new text.Hash<Text>) - (/.install "get" virtual//get) - (/.install "put" virtual//put)))) - (dict.merge (<| (/.prefix "invoke") - (|> (dict.new text.Hash<Text>) - (/.install "static" invoke//static) - (/.install "virtual" invoke//virtual) - (/.install "special" invoke//special) - (/.install "interface" invoke//interface) - (/.install "constructor" invoke//constructor) - ))) + (////.throw bundle.invalid-syntax extension-name)))) + +(def: bundle::member + Bundle + (<| (bundle.prefix "member") + (|> bundle.empty + (dictionary.merge (<| (bundle.prefix "static") + (|> bundle.empty + (bundle.install "get" static::get) + (bundle.install "put" static::put)))) + (dictionary.merge (<| (bundle.prefix "virtual") + (|> bundle.empty + (bundle.install "get" virtual::get) + (bundle.install "put" virtual::put)))) + (dictionary.merge (<| (bundle.prefix "invoke") + (|> bundle.empty + (bundle.install "static" invoke::static) + (bundle.install "virtual" invoke::virtual) + (bundle.install "special" invoke::special) + (bundle.install "interface" invoke::interface) + (bundle.install "constructor" invoke::constructor) + ))) ))) -(def: #export extensions - /.Bundle - (<| (/.prefix "jvm") - (|> (dict.new text.Hash<Text>) - (dict.merge conversion-procs) - (dict.merge int-procs) - (dict.merge long-procs) - (dict.merge float-procs) - (dict.merge double-procs) - (dict.merge char-procs) - (dict.merge array-procs) - (dict.merge object-procs) - (dict.merge member-procs) +(def: #export bundle + Bundle + (<| (bundle.prefix "jvm") + (|> bundle.empty + (dictionary.merge bundle::conversion) + (dictionary.merge bundle::int) + (dictionary.merge bundle::long) + (dictionary.merge bundle::float) + (dictionary.merge bundle::double) + (dictionary.merge bundle::char) + (dictionary.merge bundle::array) + (dictionary.merge bundle::object) + (dictionary.merge bundle::member) ))) diff --git a/stdlib/source/lux/language/compiler/extension/bundle.lux b/stdlib/source/lux/language/compiler/extension/bundle.lux index 315d05523..222ad7f5e 100644 --- a/stdlib/source/lux/language/compiler/extension/bundle.lux +++ b/stdlib/source/lux/language/compiler/extension/bundle.lux @@ -20,9 +20,13 @@ (ex.report ["Extension" name])) ## [Utils] +(def: #export empty + //.Bundle + (dict.new text.Hash<Text>)) + (def: #export (install name anonymous) (All [s i o] - (-> Text (-> Text (//.Handler s i o)) + (-> Text (//.Handler s i o) (-> (//.Bundle s i o) (//.Bundle s i o)))) (dict.put name anonymous)) |