diff options
-rw-r--r-- | new-luxc/source/luxc/lang/translation/jvm/procedure/host.lux | 168 | ||||
-rw-r--r-- | stdlib/source/lux/data/collection/array.lux | 101 | ||||
-rw-r--r-- | stdlib/source/lux/host/jvm/loader.old.lux (renamed from stdlib/source/lux/host/jvm/loader.jvm.lux) | 0 | ||||
-rw-r--r-- | stdlib/source/lux/tool/compiler/phase/extension/analysis/host.old.lux | 184 |
4 files changed, 255 insertions, 198 deletions
diff --git a/new-luxc/source/luxc/lang/translation/jvm/procedure/host.lux b/new-luxc/source/luxc/lang/translation/jvm/procedure/host.lux index 45e025d0b..2e39860fc 100644 --- a/new-luxc/source/luxc/lang/translation/jvm/procedure/host.lux +++ b/new-luxc/source/luxc/lang/translation/jvm/procedure/host.lux @@ -61,60 +61,60 @@ <conversion> (_.wrap <wrap>))))] - [convert::double-to-float #$.Double _.D2F #$.Float] - [convert::double-to-int #$.Double _.D2I #$.Int] - [convert::double-to-long #$.Double _.D2L #$.Long] - [convert::float-to-double #$.Float _.F2D #$.Double] - [convert::float-to-int #$.Float _.F2I #$.Int] - [convert::float-to-long #$.Float _.F2L #$.Long] - [convert::int-to-byte #$.Int _.I2B #$.Byte] - [convert::int-to-char #$.Int _.I2C #$.Char] - [convert::int-to-double #$.Int _.I2D #$.Double] - [convert::int-to-float #$.Int _.I2F #$.Float] - [convert::int-to-long #$.Int _.I2L #$.Long] - [convert::int-to-short #$.Int _.I2S #$.Short] - [convert::long-to-double #$.Long _.L2D #$.Double] - [convert::long-to-float #$.Long _.L2F #$.Float] - [convert::long-to-int #$.Long _.L2I #$.Int] - [convert::long-to-short #$.Long L2S #$.Short] - [convert::long-to-byte #$.Long L2B #$.Byte] - [convert::long-to-char #$.Long L2C #$.Char] - [convert::char-to-byte #$.Char _.I2B #$.Byte] - [convert::char-to-short #$.Char _.I2S #$.Short] - [convert::char-to-int #$.Char _.NOP #$.Int] - [convert::char-to-long #$.Char _.I2L #$.Long] - [convert::byte-to-long #$.Byte _.I2L #$.Long] - [convert::short-to-long #$.Short _.I2L #$.Long] + [conversion::double-to-float #$.Double _.D2F #$.Float] + [conversion::double-to-int #$.Double _.D2I #$.Int] + [conversion::double-to-long #$.Double _.D2L #$.Long] + [conversion::float-to-double #$.Float _.F2D #$.Double] + [conversion::float-to-int #$.Float _.F2I #$.Int] + [conversion::float-to-long #$.Float _.F2L #$.Long] + [conversion::int-to-byte #$.Int _.I2B #$.Byte] + [conversion::int-to-char #$.Int _.I2C #$.Char] + [conversion::int-to-double #$.Int _.I2D #$.Double] + [conversion::int-to-float #$.Int _.I2F #$.Float] + [conversion::int-to-long #$.Int _.I2L #$.Long] + [conversion::int-to-short #$.Int _.I2S #$.Short] + [conversion::long-to-double #$.Long _.L2D #$.Double] + [conversion::long-to-float #$.Long _.L2F #$.Float] + [conversion::long-to-int #$.Long _.L2I #$.Int] + [conversion::long-to-short #$.Long L2S #$.Short] + [conversion::long-to-byte #$.Long L2B #$.Byte] + [conversion::long-to-char #$.Long L2C #$.Char] + [conversion::char-to-byte #$.Char _.I2B #$.Byte] + [conversion::char-to-short #$.Char _.I2S #$.Short] + [conversion::char-to-int #$.Char _.NOP #$.Int] + [conversion::char-to-long #$.Char _.I2L #$.Long] + [conversion::byte-to-long #$.Byte _.I2L #$.Long] + [conversion::short-to-long #$.Short _.I2L #$.Long] ) (def: conversion Bundle - (<| (bundle.prefix "convert") + (<| (bundle.prefix "conversion") (|> (: Bundle bundle.empty) - (bundle.install "double-to-float" (unary convert::double-to-float)) - (bundle.install "double-to-int" (unary convert::double-to-int)) - (bundle.install "double-to-long" (unary convert::double-to-long)) - (bundle.install "float-to-double" (unary convert::float-to-double)) - (bundle.install "float-to-int" (unary convert::float-to-int)) - (bundle.install "float-to-long" (unary convert::float-to-long)) - (bundle.install "int-to-byte" (unary convert::int-to-byte)) - (bundle.install "int-to-char" (unary convert::int-to-char)) - (bundle.install "int-to-double" (unary convert::int-to-double)) - (bundle.install "int-to-float" (unary convert::int-to-float)) - (bundle.install "int-to-long" (unary convert::int-to-long)) - (bundle.install "int-to-short" (unary convert::int-to-short)) - (bundle.install "long-to-double" (unary convert::long-to-double)) - (bundle.install "long-to-float" (unary convert::long-to-float)) - (bundle.install "long-to-int" (unary convert::long-to-int)) - (bundle.install "long-to-short" (unary convert::long-to-short)) - (bundle.install "long-to-byte" (unary convert::long-to-byte)) - (bundle.install "long-to-char" (unary convert::long-to-char)) - (bundle.install "char-to-byte" (unary convert::char-to-byte)) - (bundle.install "char-to-short" (unary convert::char-to-short)) - (bundle.install "char-to-int" (unary convert::char-to-int)) - (bundle.install "char-to-long" (unary convert::char-to-long)) - (bundle.install "byte-to-long" (unary convert::byte-to-long)) - (bundle.install "short-to-long" (unary convert::short-to-long)) + (bundle.install "double-to-float" (unary conversion::double-to-float)) + (bundle.install "double-to-int" (unary conversion::double-to-int)) + (bundle.install "double-to-long" (unary conversion::double-to-long)) + (bundle.install "float-to-double" (unary conversion::float-to-double)) + (bundle.install "float-to-int" (unary conversion::float-to-int)) + (bundle.install "float-to-long" (unary conversion::float-to-long)) + (bundle.install "int-to-byte" (unary conversion::int-to-byte)) + (bundle.install "int-to-char" (unary conversion::int-to-char)) + (bundle.install "int-to-double" (unary conversion::int-to-double)) + (bundle.install "int-to-float" (unary conversion::int-to-float)) + (bundle.install "int-to-long" (unary conversion::int-to-long)) + (bundle.install "int-to-short" (unary conversion::int-to-short)) + (bundle.install "long-to-double" (unary conversion::long-to-double)) + (bundle.install "long-to-float" (unary conversion::long-to-float)) + (bundle.install "long-to-int" (unary conversion::long-to-int)) + (bundle.install "long-to-short" (unary conversion::long-to-short)) + (bundle.install "long-to-byte" (unary conversion::long-to-byte)) + (bundle.install "long-to-char" (unary conversion::long-to-char)) + (bundle.install "char-to-byte" (unary conversion::char-to-byte)) + (bundle.install "char-to-short" (unary conversion::char-to-short)) + (bundle.install "char-to-int" (unary conversion::char-to-int)) + (bundle.install "char-to-long" (unary conversion::char-to-long)) + (bundle.install "byte-to-long" (unary conversion::byte-to-long)) + (bundle.install "short-to-long" (unary conversion::short-to-long)) ))) (template [<name> <op> <unwrapX> <unwrapY> <wrap>] @@ -284,37 +284,49 @@ (bundle.install "<" (binary char::<)) ))) -(def: (array::length arrayD arrayI) - (Binary Inst) - (|>> arrayI - (_.CHECKCAST arrayD) - _.ARRAYLENGTH - _.I2L - (_.wrap #$.Long))) +(def: (array-java-type nesting elem-class) + (-> Nat Text $.Type) + (_t.array nesting + (case elem-class + "boolean" _t.boolean + "byte" _t.byte + "short" _t.short + "int" _t.int + "long" _t.long + "float" _t.float + "double" _t.double + "char" _t.char + _ (_t.class elem-class (list))))) + +(def: (array::length proc generate inputs) + Handler + (case inputs + (^ (list (synthesis.i64 nesting) + (synthesis.text elem-class) + arrayS)) + (do phase.monad + [arrayI (generate arrayS)] + (wrap (|>> arrayI + (_.CHECKCAST (_t.descriptor (array-java-type (.nat nesting) elem-class))) + _.ARRAYLENGTH + _.I2L + (_.wrap #$.Long)))) + + _ + (phase.throw extension.invalid-syntax [proc %synthesis inputs]))) (def: (array::new proc generate inputs) Handler (case inputs - (^ (list (synthesis.i64 level) - (synthesis.text class) + (^ (list (synthesis.i64 nesting) + (synthesis.text elem-class) lengthS)) (do phase.monad - [lengthI (generate lengthS) - #let [arrayJT (_t.array (.nat level) - (case class - "boolean" _t.boolean - "byte" _t.byte - "short" _t.short - "int" _t.int - "long" _t.long - "float" _t.float - "double" _t.double - "char" _t.char - _ (_t.class class (list))))]] + [lengthI (generate lengthS)] (wrap (|>> lengthI (_.unwrap #$.Long) _.L2I - (_.array arrayJT)))) + (_.array (array-java-type (.nat nesting) elem-class))))) _ (phase.throw extension.invalid-syntax [proc %synthesis inputs]))) @@ -322,13 +334,14 @@ (def: (array::read proc generate inputs) Handler (case inputs - (^ (list (synthesis.text class) + (^ (list (synthesis.i64 nesting) + (synthesis.text elem-class) idxS arrayS)) (do phase.monad [arrayI (generate arrayS) idxI (generate idxS) - #let [loadI (case class + #let [loadI (case elem-class "boolean" (|>> _.BALOAD (_.wrap #$.Boolean)) "byte" (|>> _.BALOAD (_.wrap #$.Byte)) "short" (|>> _.SALOAD (_.wrap #$.Short)) @@ -339,6 +352,7 @@ "char" (|>> _.CALOAD (_.wrap #$.Char)) _ _.AALOAD)]] (wrap (|>> arrayI + (_.CHECKCAST (_t.descriptor (array-java-type (.nat nesting) elem-class))) idxI (_.unwrap #$.Long) _.L2I @@ -350,7 +364,8 @@ (def: (array::write proc generate inputs) Handler (case inputs - (^ (list (synthesis.text class) + (^ (list (synthesis.i64 nesting) + (synthesis.text elem-class) idxS valueS arrayS)) @@ -358,7 +373,7 @@ [arrayI (generate arrayS) idxI (generate idxS) valueI (generate valueS) - #let [storeI (case class + #let [storeI (case elem-class "boolean" (|>> (_.unwrap #$.Boolean) _.BASTORE) "byte" (|>> (_.unwrap #$.Byte) _.BASTORE) "short" (|>> (_.unwrap #$.Short) _.SASTORE) @@ -369,6 +384,7 @@ "char" (|>> (_.unwrap #$.Char) _.CASTORE) _ _.AASTORE)]] (wrap (|>> arrayI + (_.CHECKCAST (_t.descriptor (array-java-type (.nat nesting) elem-class))) _.DUP idxI (_.unwrap #$.Long) @@ -383,7 +399,7 @@ Bundle (<| (bundle.prefix "array") (|> (: Bundle bundle.empty) - (bundle.install "length" (unary array::length)) + (bundle.install "length" array::length) (bundle.install "new" array::new) (bundle.install "read" array::read) (bundle.install "write" array::write) diff --git a/stdlib/source/lux/data/collection/array.lux b/stdlib/source/lux/data/collection/array.lux index 04b215cf8..4cb89c71b 100644 --- a/stdlib/source/lux/data/collection/array.lux +++ b/stdlib/source/lux/data/collection/array.lux @@ -21,42 +21,75 @@ {#.doc "Mutable arrays."} (#.Primitive ..type-name (#.Cons a #.Nil))) -(def: #export (new size) - (All [a] (-> Nat (Array a))) - (`` (for {(~~ (static host.old)) - (:assume ("jvm anewarray" "(java.lang.Object )" size))}))) +(with-expansions [<elem-type> (primitive "java.lang.Object") + <array-type> (type (Array <elem-type>))] + (def: #export (new size) + (All [a] (-> Nat (Array a))) + (`` (for {(~~ (static host.old)) + (:assume ("jvm anewarray" "(java.lang.Object )" size)) -(def: #export (size xs) - (All [a] (-> (Array a) Nat)) - (`` (for {(~~ (static host.old)) - ("jvm arraylength" xs)}))) + (~~ (static host.jvm)) + (:assume + (: (Array (primitive "java.lang.Object")) + ("jvm array new" size)))}))) -(def: #export (read i xs) - (All [a] - (-> Nat (Array a) (Maybe a))) - (if (n/< (size xs) i) + (def: #export (size array) + (All [a] (-> (Array a) Nat)) (`` (for {(~~ (static host.old)) - (let [value ("jvm aaload" xs i)] - (if ("jvm object null?" value) - #.None - (#.Some value)))})) - #.None)) + ("jvm arraylength" array) + + (~~ (static host.jvm)) + ("jvm array length" (:coerce <array-type> array))}))) + + (def: #export (read index array) + (All [a] + (-> Nat (Array a) (Maybe a))) + (if (n/< (size array) index) + (`` (for {(~~ (static host.old)) + (let [value ("jvm aaload" array index)] + (if ("jvm object null?" value) + #.None + (#.Some value))) + + (~~ (static host.jvm)) + (let [value ("jvm array read" index (:coerce <array-type> array))] + (if ("jvm object null?" value) + #.None + (#.Some (:assume value))))})) + #.None)) + + (def: #export (write index value array) + (All [a] + (-> Nat a (Array a) (Array a))) + (`` (for {(~~ (static host.old)) + ("jvm aastore" array index value) + + (~~ (static host.jvm)) + (:assume + ("jvm array write" index (:coerce <elem-type> value) + (:coerce <array-type> array)))}))) + + (def: #export (delete index array) + (All [a] + (-> Nat (Array a) (Array a))) + (if (n/< (size array) index) + (`` (for {(~~ (static host.old)) + (write index (:assume ("jvm object null")) array) + + (~~ (static host.jvm)) + (write index (:assume (: <elem-type> ("jvm object null"))) array)})) + array)) + ) (def: #export (contains? index array) (All [a] (-> Nat (Array a) Bit)) (case (..read index array) (#.Some _) - #1 + true _ - #0)) - -(def: #export (write i x xs) - (All [a] - (-> Nat a (Array a) (Array a))) - (`` (for {(~~ (static host.old)) - ("jvm aastore" xs i x)}))) + false)) (def: #export (update index transform array) (All [a] @@ -75,14 +108,6 @@ (|> array (read index) (maybe.default default) transform) array)) -(def: #export (delete i xs) - (All [a] - (-> Nat (Array a) (Array a))) - (if (n/< (size xs) i) - (`` (for {(~~ (static host.old)) - (write i (:assume ("jvm object null")) xs)})) - xs)) - (def: #export (copy length src-start src-array dest-start dest-array) (All [a] (-> Nat Nat (Array a) Nat (Array a) @@ -221,14 +246,14 @@ (and prev (case [(read idx xs) (read idx ys)] [#.None #.None] - #1 + true [(#.Some x) (#.Some y)] (,@= x y) _ - #0))) - #1 + false))) + true (list.indices sxs)))))) (structure: #export monoid (All [a] (Monoid (Array a))) @@ -287,6 +312,6 @@ (recur (inc idx))) <init>))))] - [every? #1 and] - [any? #0 or] + [every? true and] + [any? false or] ) diff --git a/stdlib/source/lux/host/jvm/loader.jvm.lux b/stdlib/source/lux/host/jvm/loader.old.lux index 0ca92fa23..0ca92fa23 100644 --- a/stdlib/source/lux/host/jvm/loader.jvm.lux +++ b/stdlib/source/lux/host/jvm/loader.old.lux diff --git a/stdlib/source/lux/tool/compiler/phase/extension/analysis/host.old.lux b/stdlib/source/lux/tool/compiler/phase/extension/analysis/host.old.lux index 13762272e..fe9a63f09 100644 --- a/stdlib/source/lux/tool/compiler/phase/extension/analysis/host.old.lux +++ b/stdlib/source/lux/tool/compiler/phase/extension/analysis/host.old.lux @@ -19,7 +19,7 @@ ["." type ["." check]] ["." macro - ["s" syntax]] + ["s" syntax (#+ Syntax)]] ["." host (#+ import:)]] ["." // #_ ["#." common] @@ -30,7 +30,8 @@ [".A" type] [".A" inference]] ["#/" // #_ - ["#." analysis (#+ Analysis Operation Handler Bundle)]]]]]) + ["#." analysis (#+ Analysis Operation Handler Bundle)] + ["#." synthesis]]]]]) (type: Method-Signature {#method Type @@ -73,7 +74,6 @@ [unknown-class] [primitives-cannot-have-type-parameters] [primitives-are-not-objects] - [invalid-type-for-array-element] [unknown-field] [mistaken-field-owner] @@ -131,7 +131,7 @@ (def: bundle::conversion Bundle - (<| (///bundle.prefix "convert") + (<| (///bundle.prefix "conversion") (|> ///bundle.empty (///bundle.install "double-to-float" (//common.unary Double Float)) (///bundle.install "double-to-int" (//common.unary Double Integer)) @@ -220,6 +220,33 @@ ["char" "java.lang.Character"]) (dictionary.from-list text.hash))) +(def: (array-type-info arrayT) + (-> Type (Operation [Nat Text])) + (loop [level 0 + currentT arrayT] + (case currentT + (#.Apply inputT abstractionT) + (case (type.apply (list inputT) abstractionT) + (#.Some outputT) + (recur level outputT) + + #.None + (/////analysis.throw non-array arrayT)) + + (^ (#.Primitive (static array.type-name) (list elemT))) + (recur (inc level) elemT) + + (#.Primitive class #.Nil) + (////@wrap [level class]) + + (#.Primitive class _) + (if (dictionary.contains? class boxes) + (/////analysis.throw primitives-cannot-have-type-parameters class) + (////@wrap [level class])) + + _ + (/////analysis.throw non-array arrayT)))) + (def: array::length Handler (function (_ extension-name analyse args) @@ -229,8 +256,12 @@ [_ (typeA.infer Nat) [var-id varT] (typeA.with-env check.var) arrayA (typeA.with-type (type (Array varT)) - (analyse arrayC))] - (wrap (#/////analysis.Extension extension-name (list arrayA)))) + (analyse arrayC)) + varT (typeA.with-env (check.clean varT)) + [array-nesting elem-class] (array-type-info (type (Array varT)))] + (wrap (#/////analysis.Extension extension-name (list (/////analysis.nat array-nesting) + (/////analysis.text elem-class) + arrayA)))) _ (/////analysis.throw ///.incorrect-arity [extension-name 1 (list.size args)])))) @@ -244,26 +275,7 @@ [lengthA (typeA.with-type Nat (analyse lengthC)) expectedT (///.lift macro.expected-type) - [level elem-class] (: (Operation [Nat Text]) - (loop [analysisT expectedT - level 0] - (case analysisT - (#.Apply inputT funcT) - (case (type.apply (list inputT) funcT) - (#.Some outputT) - (recur outputT level) - - #.None - (/////analysis.throw non-array expectedT)) - - (^ (#.Primitive "#Array" (list elemT))) - (recur elemT (inc level)) - - (#.Primitive class _) - (wrap [level class]) - - _ - (/////analysis.throw non-array expectedT)))) + [level elem-class] (array-type-info expectedT) _ (if (n/> 0 level) (wrap []) (/////analysis.throw non-array expectedT))] @@ -292,8 +304,8 @@ ([#.UnivQ] [#.ExQ]) - (#.Apply inputT funcT) - (case (type.apply (list inputT) funcT) + (#.Apply inputT abstractionT) + (case (type.apply (list inputT) abstractionT) (#.Some outputT) (check-jvm outputT) @@ -311,39 +323,25 @@ (/////analysis.throw primitives-are-not-objects name) (////@wrap name)))) -(def: (box-array-element-type elemT) - (-> Type (Operation [Type Text])) - (case elemT - (#.Primitive name #.Nil) - (let [boxed-name (|> (dictionary.get name boxes) - (maybe.default name))] - (////@wrap [(#.Primitive boxed-name #.Nil) - boxed-name])) - - (#.Primitive name _) - (if (dictionary.contains? name boxes) - (/////analysis.throw primitives-cannot-have-type-parameters name) - (////@wrap [elemT name])) - - _ - (/////analysis.throw invalid-type-for-array-element (%type elemT)))) - (def: array::read Handler (function (_ extension-name analyse args) (case args - (^ (list arrayC idxC)) + (^ (list idxC arrayC)) (do ////.monad [[var-id varT] (typeA.with-env check.var) _ (typeA.infer varT) arrayA (typeA.with-type (type (Array varT)) (analyse arrayC)) - ?elemT (typeA.with-env - (check.read var-id)) - [elemT elem-class] (box-array-element-type (maybe.default varT ?elemT)) + varT (typeA.with-env + (check.clean varT)) + [nesting elem-class] (array-type-info varT) idxA (typeA.with-type Nat (analyse idxC))] - (wrap (#/////analysis.Extension extension-name (list (/////analysis.text elem-class) idxA arrayA)))) + (wrap (#/////analysis.Extension extension-name (list (/////analysis.nat (inc nesting)) + (/////analysis.text elem-class) + idxA + arrayA)))) _ (/////analysis.throw ///.incorrect-arity [extension-name 2 (list.size args)])))) @@ -352,20 +350,24 @@ Handler (function (_ extension-name analyse args) (case args - (^ (list arrayC idxC valueC)) + (^ (list idxC valueC arrayC)) (do ////.monad [[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 - (check.read var-id)) - [valueT elem-class] (box-array-element-type (maybe.default varT ?elemT)) + varT (typeA.with-env + (check.clean varT)) + [nesting elem-class] (array-type-info varT) idxA (typeA.with-type Nat (analyse idxC)) - valueA (typeA.with-type valueT + valueA (typeA.with-type varT (analyse valueC))] - (wrap (#/////analysis.Extension extension-name (list (/////analysis.text elem-class) idxA valueA arrayA)))) + (wrap (#/////analysis.Extension extension-name (list (/////analysis.nat (inc nesting)) + (/////analysis.text elem-class) + idxA + valueA + arrayA)))) _ (/////analysis.throw ///.incorrect-arity [extension-name 3 (list.size args)])))) @@ -533,7 +535,7 @@ (wrap (#/////analysis.Extension extension-name (list (/////analysis.text class))))) _ - (/////analysis.throw ///.invalid-syntax [extension-name args])) + (/////analysis.throw ///.invalid-syntax [extension-name %code args])) _ (/////analysis.throw ///.incorrect-arity [extension-name 1 (list.size args)])))) @@ -556,7 +558,7 @@ (/////analysis.throw cannot-possibly-be-an-instance (format object-class " !<= " class)))) _ - (/////analysis.throw ///.invalid-syntax [extension-name args])) + (/////analysis.throw ///.invalid-syntax [extension-name %code args])) _ (/////analysis.throw ///.incorrect-arity [extension-name 2 (list.size args)])))) @@ -644,7 +646,7 @@ [innerT (|> java-type GenericArrayType::getGenericComponentType (java-type-to-lux-type mappings))] - (wrap (#.Primitive "#Array" (list innerT)))) + (wrap (#.Primitive array.type-name (list innerT)))) _) ## else @@ -756,7 +758,7 @@ " For value: " (%code valueC) text.new-line)))) _ - (/////analysis.throw ///.invalid-syntax [extension-name args])))) + (/////analysis.throw ///.invalid-syntax [extension-name %code args])))) (def: bundle::object Bundle @@ -845,7 +847,7 @@ (wrap (#/////analysis.Extension extension-name (list (/////analysis.text class) (/////analysis.text field))))) _ - (/////analysis.throw ///.invalid-syntax [extension-name args])) + (/////analysis.throw ///.invalid-syntax [extension-name %code args])) _ (/////analysis.throw ///.incorrect-arity [extension-name 2 (list.size args)])))) @@ -867,7 +869,7 @@ (wrap (#/////analysis.Extension extension-name (list (/////analysis.text class) (/////analysis.text field) valueA)))) _ - (/////analysis.throw ///.invalid-syntax [extension-name args])) + (/////analysis.throw ///.invalid-syntax [extension-name %code args])) _ (/////analysis.throw ///.incorrect-arity [extension-name 3 (list.size args)])))) @@ -886,7 +888,7 @@ (wrap (#/////analysis.Extension extension-name (list (/////analysis.text class) (/////analysis.text field) objectA)))) _ - (/////analysis.throw ///.invalid-syntax [extension-name args])) + (/////analysis.throw ///.invalid-syntax [extension-name %code args])) _ (/////analysis.throw ///.incorrect-arity [extension-name 3 (list.size args)])))) @@ -910,7 +912,7 @@ (wrap (#/////analysis.Extension extension-name (list (/////analysis.text class) (/////analysis.text field) valueA objectA)))) _ - (/////analysis.throw ///.invalid-syntax [extension-name args])) + (/////analysis.throw ///.invalid-syntax [extension-name %code args])) _ (/////analysis.throw ///.incorrect-arity [extension-name 4 (list.size args)])))) @@ -1163,6 +1165,10 @@ candidates (/////analysis.throw too-many-candidates [class-name ..constructor-method candidates])))) +(def: typed-input + (Syntax [Text Code]) + (s.tuple (p.and s.text s.any))) + (def: (decorate-inputs typesT inputsA) (-> (List Text) (List Analysis) (List Analysis)) (|> inputsA @@ -1174,24 +1180,26 @@ Handler (function (_ extension-name analyse args) (case (: (Error [Text Text (List [Text Code])]) - (s.run args ($_ p.and s.text s.text (p.some (s.tuple (p.and s.text s.any)))))) + (s.run args ($_ p.and s.text s.text (p.some ..typed-input)))) (#error.Success [class method argsTC]) (do ////.monad [#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 (#/////analysis.Extension extension-name (list& (/////analysis.text class) (/////analysis.text method) - (/////analysis.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))))) _ - (/////analysis.throw ///.invalid-syntax [extension-name args])))) + (/////analysis.throw ///.invalid-syntax [extension-name %code args])))) (def: invoke::virtual Handler (function (_ extension-name analyse args) (case (: (Error [Text Text Code (List [Text Code])]) - (s.run args ($_ p.and s.text s.text s.any (p.some (s.tuple (p.and s.text s.any)))))) + (s.run args ($_ p.and s.text s.text s.any (p.some ..typed-input)))) (#error.Success [class method objectC argsTC]) (do ////.monad [#let [argsT (list@map product.left argsTC)] @@ -1204,34 +1212,39 @@ _ (undefined))] outputJC (check-jvm outputT)] - (wrap (#/////analysis.Extension extension-name (list& (/////analysis.text class) (/////analysis.text method) - (/////analysis.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))))) _ - (/////analysis.throw ///.invalid-syntax [extension-name args])))) + (/////analysis.throw ///.invalid-syntax [extension-name %code args])))) (def: invoke::special Handler (function (_ extension-name analyse args) - (case (: (Error [(List Code) [Text Text Code (List [Text Code]) Any]]) - (p.run args ($_ p.and s.text s.text s.any (p.some (s.tuple (p.and s.text s.any))) s.end!))) - (#error.Success [_ [class method objectC argsTC _]]) + (case (: (Error [Text Text Code (List [Text Code])]) + (s.run args ($_ p.and s.text s.text s.any (p.some ..typed-input)))) + (#error.Success [class method objectC argsTC]) (do ////.monad [#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 (#/////analysis.Extension extension-name (list& (/////analysis.text class) (/////analysis.text method) - (/////analysis.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))))) _ - (/////analysis.throw ///.invalid-syntax [extension-name args])))) + (/////analysis.throw ///.invalid-syntax [extension-name %code args])))) (def: invoke::interface Handler (function (_ extension-name analyse args) (case (: (Error [Text Text Code (List [Text Code])]) - (s.run args ($_ p.and s.text s.text s.any (p.some (s.tuple (p.and s.text s.any)))))) + (s.run args ($_ p.and s.text s.text s.any (p.some ..typed-input)))) (#error.Success [class-name method objectC argsTC]) (do ////.monad [#let [argsT (list@map product.left argsTC)] @@ -1242,26 +1255,29 @@ [outputT argsA] (inferenceA.general analyse methodT (list& objectC (list@map product.right argsTC))) outputJC (check-jvm outputT)] (wrap (#/////analysis.Extension extension-name - (list& (/////analysis.text class-name) (/////analysis.text method) (/////analysis.text outputJC) + (list& (/////analysis.text class-name) + (/////analysis.text method) + (/////analysis.text outputJC) (decorate-inputs argsT argsA))))) _ - (/////analysis.throw ///.invalid-syntax [extension-name args])))) + (/////analysis.throw ///.invalid-syntax [extension-name %code args])))) (def: invoke::constructor Handler (function (_ extension-name analyse args) (case (: (Error [Text (List [Text Code])]) - (s.run args ($_ p.and s.text (p.some (s.tuple (p.and s.text s.any)))))) + (s.run args ($_ p.and s.text (p.some ..typed-input)))) (#error.Success [class argsTC]) (do ////.monad [#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 (#/////analysis.Extension extension-name (list& (/////analysis.text class) (decorate-inputs argsT argsA))))) + (wrap (#/////analysis.Extension extension-name (list& (/////analysis.text class) + (decorate-inputs argsT argsA))))) _ - (/////analysis.throw ///.invalid-syntax [extension-name args])))) + (/////analysis.throw ///.invalid-syntax [extension-name %code args])))) (def: bundle::member Bundle |