diff options
Diffstat (limited to 'new-luxc/source/luxc/lang/analysis/procedure/host.jvm.lux')
| -rw-r--r-- | new-luxc/source/luxc/lang/analysis/procedure/host.jvm.lux | 1130 |
1 files changed, 565 insertions, 565 deletions
diff --git a/new-luxc/source/luxc/lang/analysis/procedure/host.jvm.lux b/new-luxc/source/luxc/lang/analysis/procedure/host.jvm.lux index bb388434f..3c29410d0 100644 --- a/new-luxc/source/luxc/lang/analysis/procedure/host.jvm.lux +++ b/new-luxc/source/luxc/lang/analysis/procedure/host.jvm.lux @@ -1,4 +1,4 @@ -(;module: +(.module: [lux #- char] (lux (control [monad #+ do] ["p" parser] @@ -21,10 +21,10 @@ (type ["tc" check])) [host]) (luxc ["&" lang] - (lang ["&;" host] + (lang ["&." host] ["la" analysis] - (analysis ["&;" common] - [";A" inference]))) + (analysis ["&." common] + [".A" inference]))) ["@" //common] ) @@ -32,7 +32,7 @@ (def: (wrong-syntax procedure args) (-> Text (List Code) Text) (format "Procedure: " procedure "\n" - "Arguments: " (%code (code;tuple args)))) + "Arguments: " (%code (code.tuple args)))) (exception: #export JVM-Type-Is-Not-Class) @@ -74,7 +74,7 @@ (def: #export null-class Text "#Null") (do-template [<name> <class>] - [(def: #export <name> Type (#;Primitive <class> (list)))] + [(def: #export <name> Type (#.Primitive <class> (list)))] ## Boxes [Boolean "java.lang.Boolean"] @@ -99,52 +99,52 @@ ) (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)) + @.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)) ))) (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 + (<| (@.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>)) )))] [int-procs "int" Integer] @@ -153,16 +153,16 @@ (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 + (<| (@.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)) )))] [float-procs "float" Float] @@ -170,11 +170,11 @@ ) (def: char-procs - @;Bundle - (<| (@;prefix "char") - (|> (dict;new text;Hash<Text>) - (@;install "=" (@;binary Character Character Boolean)) - (@;install "<" (@;binary Character Character Boolean)) + @.Bundle + (<| (@.prefix "char") + (|> (dict.new text.Hash<Text>) + (@.install "=" (@.binary Character Character Boolean)) + (@.install "<" (@.binary Character Character Boolean)) ))) (def: #export boxes @@ -187,439 +187,439 @@ ["float" "java.lang.Float"] ["double" "java.lang.Double"] ["char" "java.lang.Character"]) - (dict;from-list text;Hash<Text>))) + (dict.from-list text.Hash<Text>))) (def: (array-length proc) - (-> Text @;Proc) + (-> Text @.Proc) (function [analyse eval args] (case args (^ (list arrayC)) - (do macro;Monad<Meta> - [_ (&;infer Nat) - [var-id varT] (&;with-type-env tc;var) - arrayA (&;with-type (type (Array varT)) + (do macro.Monad<Meta> + [_ (&.infer Nat) + [var-id varT] (&.with-type-env tc.var) + arrayA (&.with-type (type (Array varT)) (analyse arrayC))] - (wrap (la;procedure proc (list arrayA)))) + (wrap (la.procedure proc (list arrayA)))) _ - (&;throw @;Incorrect-Procedure-Arity (@;wrong-arity proc +1 (list;size args)))))) + (&.throw @.Incorrect-Procedure-Arity (@.wrong-arity proc +1 (list.size args)))))) (def: (array-new proc) - (-> Text @;Proc) + (-> Text @.Proc) (function [analyse eval args] (case args (^ (list lengthC)) - (do macro;Monad<Meta> - [lengthA (&;with-type Nat + (do macro.Monad<Meta> + [lengthA (&.with-type Nat (analyse lengthC)) - expectedT macro;expected-type + expectedT macro.expected-type [level elem-class] (: (Meta [Nat Text]) (loop [analysisT expectedT level +0] (case analysisT - (#;Apply inputT funcT) - (case (type;apply (list inputT) funcT) - (#;Some outputT) + (#.Apply inputT funcT) + (case (type.apply (list inputT) funcT) + (#.Some outputT) (recur outputT level) - #;None - (&;throw Non-Array (%type expectedT))) + #.None + (&.throw Non-Array (%type expectedT))) - (^ (#;Primitive "#Array" (list elemT))) - (recur elemT (n.inc level)) + (^ (#.Primitive "#Array" (list elemT))) + (recur elemT (n/inc level)) - (#;Primitive class _) + (#.Primitive class _) (wrap [level class]) _ - (&;throw Non-Array (%type expectedT))))) - _ (if (n.> +0 level) + (&.throw Non-Array (%type expectedT))))) + _ (if (n/> +0 level) (wrap []) - (&;throw Non-Array (%type expectedT)))] - (wrap (la;procedure proc (list (code;nat (n.dec level)) (code;text elem-class) lengthA)))) + (&.throw Non-Array (%type expectedT)))] + (wrap (la.procedure proc (list (code.nat (n/dec level)) (code.text elem-class) lengthA)))) _ - (&;throw @;Incorrect-Procedure-Arity (@;wrong-arity proc +1 (list;size args)))))) + (&.throw @.Incorrect-Procedure-Arity (@.wrong-arity proc +1 (list.size args)))))) (def: (check-jvm objectT) (-> Type (Meta Text)) (case objectT - (#;Primitive name _) + (#.Primitive name _) (macro/wrap name) - (#;Named name unnamed) + (#.Named name unnamed) (check-jvm unnamed) - (#;Var id) + (#.Var id) (macro/wrap "java.lang.Object") (^template [<tag>] (<tag> env unquantified) (check-jvm unquantified)) - ([#;UnivQ] - [#;ExQ]) + ([#.UnivQ] + [#.ExQ]) - (#;Apply inputT funcT) - (case (type;apply (list inputT) funcT) - (#;Some outputT) + (#.Apply inputT funcT) + (case (type.apply (list inputT) funcT) + (#.Some outputT) (check-jvm outputT) - #;None - (&;throw Non-Object (%type objectT))) + #.None + (&.throw Non-Object (%type objectT))) _ - (&;throw Non-Object (%type objectT)))) + (&.throw Non-Object (%type objectT)))) (def: (check-object objectT) (-> Type (Meta Text)) - (do macro;Monad<Meta> + (do macro.Monad<Meta> [name (check-jvm objectT)] - (if (dict;contains? name boxes) - (&;throw Primitives-Are-Not-Objects name) + (if (dict.contains? name boxes) + (&.throw Primitives-Are-Not-Objects name) (macro/wrap name)))) (def: (box-array-element-type elemT) (-> Type (Meta [Type Text])) (case elemT - (#;Primitive name #;Nil) - (let [boxed-name (|> (dict;get name boxes) - (maybe;default name))] - (macro/wrap [(#;Primitive boxed-name #;Nil) + (#.Primitive name #.Nil) + (let [boxed-name (|> (dict.get name boxes) + (maybe.default name))] + (macro/wrap [(#.Primitive boxed-name #.Nil) boxed-name])) - (#;Primitive name _) - (if (dict;contains? name boxes) - (&;throw Primitives-Cannot-Have-Type-Parameters name) + (#.Primitive name _) + (if (dict.contains? name boxes) + (&.throw Primitives-Cannot-Have-Type-Parameters name) (macro/wrap [elemT name])) _ - (&;throw Invalid-Type-For-Array-Element (%type elemT)))) + (&.throw Invalid-Type-For-Array-Element (%type elemT)))) (def: (array-read proc) - (-> Text @;Proc) + (-> Text @.Proc) (function [analyse eval args] (case args (^ (list arrayC idxC)) - (do macro;Monad<Meta> - [[var-id varT] (&;with-type-env tc;var) - _ (&;infer varT) - arrayA (&;with-type (type (Array varT)) + (do macro.Monad<Meta> + [[var-id varT] (&.with-type-env tc.var) + _ (&.infer varT) + arrayA (&.with-type (type (Array varT)) (analyse arrayC)) - ?elemT (&;with-type-env - (tc;read var-id)) - [elemT elem-class] (box-array-element-type (maybe;default varT ?elemT)) - idxA (&;with-type Nat + ?elemT (&.with-type-env + (tc.read var-id)) + [elemT elem-class] (box-array-element-type (maybe.default varT ?elemT)) + idxA (&.with-type Nat (analyse idxC))] - (wrap (la;procedure proc (list (code;text elem-class) idxA arrayA)))) + (wrap (la.procedure proc (list (code.text elem-class) idxA arrayA)))) _ - (&;throw @;Incorrect-Procedure-Arity (@;wrong-arity proc +2 (list;size args)))))) + (&.throw @.Incorrect-Procedure-Arity (@.wrong-arity proc +2 (list.size args)))))) (def: (array-write proc) - (-> Text @;Proc) + (-> Text @.Proc) (function [analyse eval args] (case args (^ (list arrayC idxC valueC)) - (do macro;Monad<Meta> - [[var-id varT] (&;with-type-env tc;var) - _ (&;infer (type (Array varT))) - arrayA (&;with-type (type (Array varT)) + (do macro.Monad<Meta> + [[var-id varT] (&.with-type-env tc.var) + _ (&.infer (type (Array varT))) + arrayA (&.with-type (type (Array varT)) (analyse arrayC)) - ?elemT (&;with-type-env - (tc;read var-id)) - [valueT elem-class] (box-array-element-type (maybe;default varT ?elemT)) - idxA (&;with-type Nat + ?elemT (&.with-type-env + (tc.read var-id)) + [valueT elem-class] (box-array-element-type (maybe.default varT ?elemT)) + idxA (&.with-type Nat (analyse idxC)) - valueA (&;with-type valueT + valueA (&.with-type valueT (analyse valueC))] - (wrap (la;procedure proc (list (code;text elem-class) idxA valueA arrayA)))) + (wrap (la.procedure proc (list (code.text elem-class) idxA valueA arrayA)))) _ - (&;throw @;Incorrect-Procedure-Arity (@;wrong-arity proc +3 (list;size args)))))) + (&.throw @.Incorrect-Procedure-Arity (@.wrong-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) + @.Bundle + (<| (@.prefix "array") + (|> (dict.new text.Hash<Text>) + (@.install "length" array-length) + (@.install "new" array-new) + (@.install "read" array-read) + (@.install "write" array-write) ))) (def: (object-null proc) - (-> Text @;Proc) + (-> Text @.Proc) (function [analyse eval args] (case args (^ (list)) - (do macro;Monad<Meta> - [expectedT macro;expected-type + (do macro.Monad<Meta> + [expectedT macro.expected-type _ (check-object expectedT)] - (wrap (la;procedure proc (list)))) + (wrap (la.procedure proc (list)))) _ - (&;throw @;Incorrect-Procedure-Arity (@;wrong-arity proc +0 (list;size args)))))) + (&.throw @.Incorrect-Procedure-Arity (@.wrong-arity proc +0 (list.size args)))))) (def: (object-null? proc) - (-> Text @;Proc) + (-> Text @.Proc) (function [analyse eval args] (case args (^ (list objectC)) - (do macro;Monad<Meta> - [_ (&;infer Bool) - [objectT objectA] (&common;with-unknown-type + (do macro.Monad<Meta> + [_ (&.infer Bool) + [objectT objectA] (&common.with-unknown-type (analyse objectC)) _ (check-object objectT)] - (wrap (la;procedure proc (list objectA)))) + (wrap (la.procedure proc (list objectA)))) _ - (&;throw @;Incorrect-Procedure-Arity (@;wrong-arity proc +1 (list;size args)))))) + (&.throw @.Incorrect-Procedure-Arity (@.wrong-arity proc +1 (list.size args)))))) (def: (object-synchronized proc) - (-> Text @;Proc) + (-> Text @.Proc) (function [analyse eval args] (case args (^ (list monitorC exprC)) - (do macro;Monad<Meta> - [[monitorT monitorA] (&common;with-unknown-type + (do macro.Monad<Meta> + [[monitorT monitorA] (&common.with-unknown-type (analyse monitorC)) _ (check-object monitorT) exprA (analyse exprC)] - (wrap (la;procedure proc (list monitorA exprA)))) + (wrap (la.procedure proc (list monitorA exprA)))) _ - (&;throw @;Incorrect-Procedure-Arity (@;wrong-arity proc +2 (list;size args)))))) + (&.throw @.Incorrect-Procedure-Arity (@.wrong-arity proc +2 (list.size args)))))) -(host;import java.lang.Object +(host.import java/lang/Object (equals [Object] boolean)) -(host;import java.lang.ClassLoader) +(host.import java/lang/ClassLoader) -(host;import #long java.lang.reflect.Type +(host.import #long java/lang/reflect/Type (getTypeName [] String)) -(host;import java.lang.reflect.GenericArrayType - (getGenericComponentType [] java.lang.reflect.Type)) +(host.import java/lang/reflect/GenericArrayType + (getGenericComponentType [] java/lang/reflect/Type)) -(host;import java.lang.reflect.ParameterizedType - (getRawType [] java.lang.reflect.Type) - (getActualTypeArguments [] (Array java.lang.reflect.Type))) +(host.import java/lang/reflect/ParameterizedType + (getRawType [] java/lang/reflect/Type) + (getActualTypeArguments [] (Array java/lang/reflect/Type))) -(host;import (java.lang.reflect.TypeVariable d) +(host.import (java/lang/reflect/TypeVariable d) (getName [] String) - (getBounds [] (Array java.lang.reflect.Type))) + (getBounds [] (Array java/lang/reflect/Type))) -(host;import (java.lang.reflect.WildcardType d) - (getLowerBounds [] (Array java.lang.reflect.Type)) - (getUpperBounds [] (Array java.lang.reflect.Type))) +(host.import (java/lang/reflect/WildcardType d) + (getLowerBounds [] (Array java/lang/reflect/Type)) + (getUpperBounds [] (Array java/lang/reflect/Type))) -(host;import java.lang.reflect.Modifier +(host.import java/lang/reflect/Modifier (#static isStatic [int] boolean) (#static isFinal [int] boolean) (#static isInterface [int] boolean) (#static isAbstract [int] boolean)) -(host;import java.lang.reflect.Field - (getDeclaringClass [] (java.lang.Class Object)) +(host.import java/lang/reflect/Field + (getDeclaringClass [] (java/lang/Class Object)) (getModifiers [] int) - (getGenericType [] java.lang.reflect.Type)) + (getGenericType [] java/lang/reflect/Type)) -(host;import java.lang.reflect.Method +(host.import java/lang/reflect/Method (getName [] String) (getModifiers [] int) (getDeclaringClass [] (Class Object)) (getTypeParameters [] (Array (TypeVariable Method))) - (getGenericParameterTypes [] (Array java.lang.reflect.Type)) - (getGenericReturnType [] java.lang.reflect.Type) - (getGenericExceptionTypes [] (Array java.lang.reflect.Type))) + (getGenericParameterTypes [] (Array java/lang/reflect/Type)) + (getGenericReturnType [] java/lang/reflect/Type) + (getGenericExceptionTypes [] (Array java/lang/reflect/Type))) -(host;import (java.lang.reflect.Constructor c) +(host.import (java/lang/reflect/Constructor c) (getModifiers [] int) (getDeclaringClass [] (Class c)) (getTypeParameters [] (Array (TypeVariable (Constructor c)))) - (getGenericParameterTypes [] (Array java.lang.reflect.Type)) - (getGenericExceptionTypes [] (Array java.lang.reflect.Type))) + (getGenericParameterTypes [] (Array java/lang/reflect/Type)) + (getGenericExceptionTypes [] (Array java/lang/reflect/Type))) -(host;import (java.lang.Class c) +(host.import (java/lang/Class c) (getName [] String) (getModifiers [] int) (#static forName [String boolean ClassLoader] #try (Class Object)) (isAssignableFrom [(Class Object)] boolean) (getTypeParameters [] (Array (TypeVariable (Class c)))) - (getGenericInterfaces [] (Array java.lang.reflect.Type)) - (getGenericSuperclass [] java.lang.reflect.Type) + (getGenericInterfaces [] (Array java/lang/reflect/Type)) + (getGenericSuperclass [] java/lang/reflect/Type) (getDeclaredField [String] #try Field) (getConstructors [] (Array (Constructor Object))) (getDeclaredMethods [] (Array Method))) (def: (load-class name) (-> Text (Meta (Class Object))) - (do macro;Monad<Meta> - [class-loader &host;class-loader] - (case (Class.forName [name false class-loader]) - (#e;Success [class]) + (do macro.Monad<Meta> + [class-loader &host.class-loader] + (case (Class::forName [name false class-loader]) + (#e.Success [class]) (wrap class) - (#e;Error error) - (&;throw Unknown-Class name)))) + (#e.Error error) + (&.throw Unknown-Class name)))) (def: (sub-class? super sub) (-> Text Text (Meta Bool)) - (do macro;Monad<Meta> + (do macro.Monad<Meta> [super (load-class super) sub (load-class sub)] - (wrap (Class.isAssignableFrom [sub] super)))) + (wrap (Class::isAssignableFrom [sub] super)))) (def: (object-throw proc) - (-> Text @;Proc) + (-> Text @.Proc) (function [analyse eval args] (case args (^ (list exceptionC)) - (do macro;Monad<Meta> - [_ (&;infer Bottom) - [exceptionT exceptionA] (&common;with-unknown-type + (do macro.Monad<Meta> + [_ (&.infer Bottom) + [exceptionT exceptionA] (&common.with-unknown-type (analyse exceptionC)) exception-class (check-object exceptionT) ? (sub-class? "java.lang.Throwable" exception-class) _ (: (Meta Unit) (if ? (wrap []) - (&;throw Non-Throwable exception-class)))] - (wrap (la;procedure proc (list exceptionA)))) + (&.throw Non-Throwable exception-class)))] + (wrap (la.procedure proc (list exceptionA)))) _ - (&;throw @;Incorrect-Procedure-Arity (@;wrong-arity proc +1 (list;size args)))))) + (&.throw @.Incorrect-Procedure-Arity (@.wrong-arity proc +1 (list.size args)))))) (def: (object-class proc) - (-> Text @;Proc) + (-> Text @.Proc) (function [analyse eval args] (case args (^ (list classC)) (case classC - [_ (#;Text class)] - (do macro;Monad<Meta> - [_ (&;infer (#;Primitive "java.lang.Class" (list (#;Primitive class (list))))) + [_ (#.Text class)] + (do macro.Monad<Meta> + [_ (&.infer (#.Primitive "java.lang.Class" (list (#.Primitive class (list))))) _ (load-class class)] - (wrap (la;procedure proc (list (code;text class))))) + (wrap (la.procedure proc (list (code.text class))))) _ - (&;throw Wrong-Syntax (wrong-syntax proc args))) + (&.throw Wrong-Syntax (wrong-syntax proc args))) _ - (&;throw @;Incorrect-Procedure-Arity (@;wrong-arity proc +1 (list;size args)))))) + (&.throw @.Incorrect-Procedure-Arity (@.wrong-arity proc +1 (list.size args)))))) (def: (object-instance? proc) - (-> Text @;Proc) + (-> Text @.Proc) (function [analyse eval args] (case args (^ (list classC objectC)) (case classC - [_ (#;Text class)] - (do macro;Monad<Meta> - [_ (&;infer Bool) - [objectT objectA] (&common;with-unknown-type + [_ (#.Text class)] + (do macro.Monad<Meta> + [_ (&.infer Bool) + [objectT objectA] (&common.with-unknown-type (analyse objectC)) object-class (check-object objectT) ? (sub-class? class object-class)] (if ? - (wrap (la;procedure proc (list (code;text class)))) - (&;throw Cannot-Possibly-Be-Instance (format object-class " !<= " class)))) + (wrap (la.procedure proc (list (code.text class)))) + (&.throw Cannot-Possibly-Be-Instance (format object-class " !<= " class)))) _ - (&;throw Wrong-Syntax (wrong-syntax proc args))) + (&.throw Wrong-Syntax (wrong-syntax proc args))) _ - (&;throw @;Incorrect-Procedure-Arity (@;wrong-arity proc +2 (list;size args)))))) + (&.throw @.Incorrect-Procedure-Arity (@.wrong-arity proc +2 (list.size 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?) + @.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?) ))) (def: type-descriptor - (-> java.lang.reflect.Type Text) - (java.lang.reflect.Type.getTypeName [])) + (-> java/lang/reflect/Type Text) + (java/lang/reflect/Type::getTypeName [])) (def: (java-type-to-class type) - (-> java.lang.reflect.Type (Meta Text)) - (cond (host;instance? Class type) - (macro/wrap (Class.getName [] (:! Class type))) + (-> java/lang/reflect/Type (Meta Text)) + (cond (host.instance? Class type) + (macro/wrap (Class::getName [] (:! Class type))) - (host;instance? ParameterizedType type) - (java-type-to-class (ParameterizedType.getRawType [] (:! ParameterizedType type))) + (host.instance? ParameterizedType type) + (java-type-to-class (ParameterizedType::getRawType [] (:! ParameterizedType type))) ## else - (&;throw Cannot-Convert-To-Class (type-descriptor type)))) + (&.throw Cannot-Convert-To-Class (type-descriptor type)))) (type: Mappings (Dict Text Type)) -(def: fresh-mappings Mappings (dict;new text;Hash<Text>)) +(def: fresh-mappings Mappings (dict.new text.Hash<Text>)) (def: (java-type-to-lux-type mappings java-type) - (-> Mappings java.lang.reflect.Type (Meta Type)) - (cond (host;instance? TypeVariable java-type) - (let [var-name (TypeVariable.getName [] (:! TypeVariable java-type))] - (case (dict;get var-name mappings) - (#;Some var-type) + (-> Mappings java/lang/reflect/Type (Meta Type)) + (cond (host.instance? TypeVariable java-type) + (let [var-name (TypeVariable::getName [] (:! TypeVariable java-type))] + (case (dict.get var-name mappings) + (#.Some var-type) (macro/wrap var-type) - #;None - (&;throw Unknown-Type-Var var-name))) + #.None + (&.throw Unknown-Type-Var var-name))) - (host;instance? WildcardType java-type) + (host.instance? WildcardType java-type) (let [java-type (:! WildcardType java-type)] - (case [(array;read +0 (WildcardType.getUpperBounds [] java-type)) - (array;read +0 (WildcardType.getLowerBounds [] java-type))] - (^or [(#;Some bound) _] [_ (#;Some bound)]) + (case [(array.read +0 (WildcardType::getUpperBounds [] java-type)) + (array.read +0 (WildcardType::getLowerBounds [] java-type))] + (^or [(#.Some bound) _] [_ (#.Some bound)]) (java-type-to-lux-type mappings bound) _ (macro/wrap Top))) - (host;instance? Class java-type) + (host.instance? Class java-type) (let [java-type (:! (Class Object) java-type) - class-name (Class.getName [] java-type)] - (macro/wrap (case (array;size (Class.getTypeParameters [] java-type)) + class-name (Class::getName [] java-type)] + (macro/wrap (case (array.size (Class::getTypeParameters [] java-type)) +0 - (#;Primitive class-name (list)) + (#.Primitive class-name (list)) arity - (|> (list;n.range +0 (n.dec arity)) - list;reverse - (list/map (|>. (n.* +2) n.inc #;Bound)) - (#;Primitive class-name) - (type;univ-q arity))))) + (|> (list.n/range +0 (n/dec arity)) + list.reverse + (list/map (|>> (n/* +2) n/inc #.Bound)) + (#.Primitive class-name) + (type.univ-q arity))))) - (host;instance? ParameterizedType java-type) + (host.instance? ParameterizedType java-type) (let [java-type (:! ParameterizedType java-type) - raw (ParameterizedType.getRawType [] java-type)] - (if (host;instance? Class raw) - (do macro;Monad<Meta> + raw (ParameterizedType::getRawType [] java-type)] + (if (host.instance? Class raw) + (do macro.Monad<Meta> [paramsT (|> java-type - (ParameterizedType.getActualTypeArguments []) - array;to-list - (monad;map @ (java-type-to-lux-type mappings)))] - (macro/wrap (#;Primitive (Class.getName [] (:! (Class Object) raw)) + (ParameterizedType::getActualTypeArguments []) + array.to-list + (monad.map @ (java-type-to-lux-type mappings)))] + (macro/wrap (#.Primitive (Class::getName [] (:! (Class Object) raw)) paramsT))) - (&;throw JVM-Type-Is-Not-Class (type-descriptor raw)))) + (&.throw JVM-Type-Is-Not-Class (type-descriptor raw)))) - (host;instance? GenericArrayType java-type) - (do macro;Monad<Meta> + (host.instance? GenericArrayType java-type) + (do macro.Monad<Meta> [innerT (|> (:! GenericArrayType java-type) - (GenericArrayType.getGenericComponentType []) + (GenericArrayType::getGenericComponentType []) (java-type-to-lux-type mappings))] - (wrap (#;Primitive "#Array" (list innerT)))) + (wrap (#.Primitive "#Array" (list innerT)))) ## else - (&;throw Cannot-Convert-To-Lux-Type (type-descriptor java-type)))) + (&.throw Cannot-Convert-To-Lux-Type (type-descriptor java-type)))) (type: Direction #In @@ -634,18 +634,18 @@ (def: (correspond-type-params class type) (-> (Class Object) Type (Meta Mappings)) (case type - (#;Primitive name params) - (let [class-name (Class.getName [] class) - class-params (array;to-list (Class.getTypeParameters [] class)) - num-class-params (list;size class-params) - num-type-params (list;size params)] + (#.Primitive name params) + (let [class-name (Class::getName [] class) + class-params (array.to-list (Class::getTypeParameters [] class)) + num-class-params (list.size class-params) + num-type-params (list.size params)] (cond (not (text/= class-name name)) - (&;throw Cannot-Correspond-Type-With-Class + (&.throw Cannot-Correspond-Type-With-Class (format "Class = " class-name "\n" "Type = " (%type type))) - (not (n.= num-class-params num-type-params)) - (&;throw Type-Parameter-Mismatch + (not (n/= num-class-params num-type-params)) + (&.throw Type-Parameter-Mismatch (format "Expected: " (%i (nat-to-int num-class-params)) "\n" " Actual: " (%i (nat-to-int num-type-params)) "\n" " Class: " class-name "\n" @@ -653,28 +653,28 @@ ## else (macro/wrap (|> params - (list;zip2 (list/map (TypeVariable.getName []) class-params)) - (dict;from-list text;Hash<Text>))) + (list.zip2 (list/map (TypeVariable::getName []) class-params)) + (dict.from-list text.Hash<Text>))) )) _ - (&;throw Non-JVM-Type (%type type)))) + (&.throw Non-JVM-Type (%type type)))) (def: (cast direction to from) (-> Direction Type Type (Meta [Text Type])) - (do macro;Monad<Meta> + (do macro.Monad<Meta> [to-name (check-jvm to) from-name (check-jvm from)] - (cond (dict;contains? to-name boxes) - (let [box (maybe;assume (dict;get to-name boxes))] + (cond (dict.contains? to-name boxes) + (let [box (maybe.assume (dict.get to-name boxes))] (if (text/= box from-name) - (wrap [(choose direction to-name from-name) (#;Primitive to-name (list))]) - (&;throw Cannot-Cast (cannot-cast to from)))) + (wrap [(choose direction to-name from-name) (#.Primitive to-name (list))]) + (&.throw Cannot-Cast (cannot-cast to from)))) - (dict;contains? from-name boxes) - (let [box (maybe;assume (dict;get from-name boxes))] + (dict.contains? from-name boxes) + (let [box (maybe.assume (dict.get from-name boxes))] (do @ - [[_ castT] (cast direction to (#;Primitive box (list)))] + [[_ castT] (cast direction to (#.Primitive box (list)))] (wrap [(choose direction to-name from-name) castT]))) (text/= to-name from-name) @@ -687,226 +687,226 @@ (do @ [to-class (load-class to-name) from-class (load-class from-name) - _ (&;assert Cannot-Cast (cannot-cast to from) - (Class.isAssignableFrom [from-class] to-class)) - candiate-parents (monad;map @ + _ (&.assert Cannot-Cast (cannot-cast to from) + (Class::isAssignableFrom [from-class] to-class)) + candiate-parents (monad.map @ (function [java-type] (do @ [class-name (java-type-to-class java-type) class (load-class class-name)] - (wrap [java-type (Class.isAssignableFrom [class] to-class)]))) - (list& (Class.getGenericSuperclass [] from-class) - (array;to-list (Class.getGenericInterfaces [] from-class))))] + (wrap [java-type (Class::isAssignableFrom [class] to-class)]))) + (list& (Class::getGenericSuperclass [] from-class) + (array.to-list (Class::getGenericInterfaces [] from-class))))] (case (|> candiate-parents - (list;filter product;right) - (list/map product;left)) - (#;Cons parent _) + (list.filter product.right) + (list/map product.left)) + (#.Cons parent _) (do @ [mapping (correspond-type-params from-class from) parentT (java-type-to-lux-type mapping parent) [_ castT] (cast direction to parentT)] (wrap [(choose direction to-name from-name) castT])) - #;Nil - (&;throw Cannot-Cast (cannot-cast to from))))))) + #.Nil + (&.throw Cannot-Cast (cannot-cast to from))))))) (def: (infer-out outputT) (-> Type (Meta [Text Type])) - (do macro;Monad<Meta> - [expectedT macro;expected-type + (do macro.Monad<Meta> + [expectedT macro.expected-type [unboxed castT] (cast #Out expectedT outputT) - _ (&;with-type-env - (tc;check expectedT castT))] + _ (&.with-type-env + (tc.check expectedT castT))] (wrap [unboxed castT]))) (def: (find-field class-name field-name) (-> Text Text (Meta [(Class Object) Field])) - (do macro;Monad<Meta> + (do macro.Monad<Meta> [class (load-class class-name)] - (case (Class.getDeclaredField [field-name] class) - (#e;Success field) - (let [owner (Field.getDeclaringClass [] field)] + (case (Class::getDeclaredField [field-name] class) + (#e.Success field) + (let [owner (Field::getDeclaringClass [] field)] (if (is owner class) (wrap [class field]) - (&;throw Mistaken-Field-Owner + (&.throw Mistaken-Field-Owner (format " Field: " field-name "\n" - " Owner Class: " (Class.getName [] owner) "\n" + " Owner Class: " (Class::getName [] owner) "\n" "Target Class: " class-name "\n")))) - (#e;Error _) - (&;throw Unknown-Field (format class-name "#" field-name))))) + (#e.Error _) + (&.throw Unknown-Field (format class-name "#" field-name))))) (def: (static-field class-name field-name) (-> Text Text (Meta [Type Bool])) - (do macro;Monad<Meta> + (do macro.Monad<Meta> [[class fieldJ] (find-field class-name field-name) - #let [modifiers (Field.getModifiers [] fieldJ)]] - (if (Modifier.isStatic [modifiers]) - (let [fieldJT (Field.getGenericType [] fieldJ)] + #let [modifiers (Field::getModifiers [] fieldJ)]] + (if (Modifier::isStatic [modifiers]) + (let [fieldJT (Field::getGenericType [] fieldJ)] (do @ [fieldT (java-type-to-lux-type fresh-mappings fieldJT)] - (wrap [fieldT (Modifier.isFinal [modifiers])]))) - (&;throw Not-Static-Field (format class-name "#" field-name))))) + (wrap [fieldT (Modifier::isFinal [modifiers])]))) + (&.throw Not-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> + (do macro.Monad<Meta> [[class fieldJ] (find-field class-name field-name) - #let [modifiers (Field.getModifiers [] fieldJ)]] - (if (not (Modifier.isStatic [modifiers])) + #let [modifiers (Field::getModifiers [] fieldJ)]] + (if (not (Modifier::isStatic [modifiers])) (do @ - [#let [fieldJT (Field.getGenericType [] fieldJ) + [#let [fieldJT (Field::getGenericType [] fieldJ) var-names (|> class - (Class.getTypeParameters []) - array;to-list - (list/map (TypeVariable.getName [])))] + (Class::getTypeParameters []) + array.to-list + (list/map (TypeVariable::getName [])))] mappings (: (Meta Mappings) (case objectT - (#;Primitive _class-name _class-params) + (#.Primitive _class-name _class-params) (do @ - [#let [num-params (list;size _class-params) - num-vars (list;size var-names)] - _ (&;assert Type-Parameter-Mismatch + [#let [num-params (list.size _class-params) + num-vars (list.size var-names)] + _ (&.assert Type-Parameter-Mismatch (format "Expected: " (%i (nat-to-int num-params)) "\n" " Actual: " (%i (nat-to-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>)))) + (n/= num-params num-vars))] + (wrap (|> (list.zip2 var-names _class-params) + (dict.from-list text.Hash<Text>)))) _ - (&;throw Non-Object (%type objectT)))) + (&.throw Non-Object (%type objectT)))) fieldT (java-type-to-lux-type mappings fieldJT)] - (wrap [fieldT (Modifier.isFinal [modifiers])])) - (&;throw Not-Virtual-Field (format class-name "#" field-name))))) + (wrap [fieldT (Modifier::isFinal [modifiers])])) + (&.throw Not-Virtual-Field (format class-name "#" field-name))))) (def: (analyse-object class analyse sourceC) - (-> Text &;Analyser Code (Meta [Type la;Analysis])) - (do macro;Monad<Meta> + (-> Text &.Analyser Code (Meta [Type la.Analysis])) + (do macro.Monad<Meta> [target-class (load-class class) targetT (java-type-to-lux-type fresh-mappings - (:! java.lang.reflect.Type + (:! java/lang/reflect/Type target-class)) - [sourceT sourceA] (&common;with-unknown-type + [sourceT sourceA] (&common.with-unknown-type (analyse sourceC)) [unboxed castT] (cast #Out targetT sourceT) - _ (&;assert Cannot-Cast (cannot-cast targetT sourceT) - (not (dict;contains? unboxed boxes)))] + _ (&.assert Cannot-Cast (cannot-cast targetT sourceT) + (not (dict.contains? unboxed boxes)))] (wrap [castT sourceA]))) (def: (analyse-input analyse targetT sourceC) - (-> &;Analyser Type Code (Meta [Type Text la;Analysis])) - (do macro;Monad<Meta> - [[sourceT sourceA] (&common;with-unknown-type + (-> &.Analyser Type Code (Meta [Type Text la.Analysis])) + (do macro.Monad<Meta> + [[sourceT sourceA] (&common.with-unknown-type (analyse sourceC)) [unboxed castT] (cast #In targetT sourceT)] (wrap [castT unboxed sourceA]))) (def: (static-get proc) - (-> Text @;Proc) + (-> Text @.Proc) (function [analyse eval args] (case args (^ (list classC fieldC)) (case [classC fieldC] - [[_ (#;Text class)] [_ (#;Text field)]] - (do macro;Monad<Meta> + [[_ (#.Text class)] [_ (#.Text field)]] + (do macro.Monad<Meta> [[fieldT final?] (static-field class field) [unboxed castT] (infer-out fieldT)] - (wrap (la;procedure proc (list (code;text class) (code;text field) - (code;text unboxed))))) + (wrap (la.procedure proc (list (code.text class) (code.text field) + (code.text unboxed))))) _ - (&;throw Wrong-Syntax (wrong-syntax proc args))) + (&.throw Wrong-Syntax (wrong-syntax proc args))) _ - (&;throw @;Incorrect-Procedure-Arity (@;wrong-arity proc +2 (list;size args)))))) + (&.throw @.Incorrect-Procedure-Arity (@.wrong-arity proc +2 (list.size args)))))) (def: (static-put proc) - (-> Text @;Proc) + (-> Text @.Proc) (function [analyse eval args] (case args (^ (list classC fieldC valueC)) (case [classC fieldC] - [[_ (#;Text class)] [_ (#;Text field)]] - (do macro;Monad<Meta> - [_ (&;infer Unit) + [[_ (#.Text class)] [_ (#.Text field)]] + (do macro.Monad<Meta> + [_ (&.infer Unit) [fieldT final?] (static-field class field) - _ (&;assert Cannot-Set-Final-Field (format class "#" field) + _ (&.assert Cannot-Set-Final-Field (format class "#" field) (not final?)) [valueT unboxed valueA] (analyse-input analyse fieldT valueC) - _ (&;with-type-env - (tc;check fieldT valueT))] - (wrap (la;procedure proc (list (code;text class) (code;text field) - (code;text unboxed) valueA)))) + _ (&.with-type-env + (tc.check fieldT valueT))] + (wrap (la.procedure proc (list (code.text class) (code.text field) + (code.text unboxed) valueA)))) _ - (&;throw Wrong-Syntax (wrong-syntax proc args))) + (&.throw Wrong-Syntax (wrong-syntax proc args))) _ - (&;throw @;Incorrect-Procedure-Arity (@;wrong-arity proc +3 (list;size args)))))) + (&.throw @.Incorrect-Procedure-Arity (@.wrong-arity proc +3 (list.size args)))))) (def: (virtual-get proc) - (-> Text @;Proc) + (-> Text @.Proc) (function [analyse eval args] (case args (^ (list classC fieldC objectC)) (case [classC fieldC] - [[_ (#;Text class)] [_ (#;Text field)]] - (do macro;Monad<Meta> + [[_ (#.Text class)] [_ (#.Text field)]] + (do macro.Monad<Meta> [[objectT objectA] (analyse-object class analyse objectC) [fieldT final?] (virtual-field class field objectT) [unboxed castT] (infer-out fieldT)] - (wrap (la;procedure proc (list (code;text class) (code;text field) - (code;text unboxed) objectA)))) + (wrap (la.procedure proc (list (code.text class) (code.text field) + (code.text unboxed) objectA)))) _ - (&;throw Wrong-Syntax (wrong-syntax proc args))) + (&.throw Wrong-Syntax (wrong-syntax proc args))) _ - (&;throw @;Incorrect-Procedure-Arity (@;wrong-arity proc +3 (list;size args)))))) + (&.throw @.Incorrect-Procedure-Arity (@.wrong-arity proc +3 (list.size args)))))) (def: (virtual-put proc) - (-> Text @;Proc) + (-> Text @.Proc) (function [analyse eval args] (case args (^ (list classC fieldC valueC objectC)) (case [classC fieldC] - [[_ (#;Text class)] [_ (#;Text field)]] - (do macro;Monad<Meta> + [[_ (#.Text class)] [_ (#.Text field)]] + (do macro.Monad<Meta> [[objectT objectA] (analyse-object class analyse objectC) - _ (&;infer objectT) + _ (&.infer objectT) [fieldT final?] (virtual-field class field objectT) - _ (&;assert Cannot-Set-Final-Field (format class "#" field) + _ (&.assert Cannot-Set-Final-Field (format class "#" field) (not final?)) [valueT unboxed valueA] (analyse-input analyse fieldT valueC)] - (wrap (la;procedure proc (list (code;text class) (code;text field) (code;text unboxed) valueA objectA)))) + (wrap (la.procedure proc (list (code.text class) (code.text field) (code.text unboxed) valueA objectA)))) _ - (&;throw Wrong-Syntax (wrong-syntax proc args))) + (&.throw Wrong-Syntax (wrong-syntax proc args))) _ - (&;throw @;Incorrect-Procedure-Arity (@;wrong-arity proc +4 (list;size args)))))) + (&.throw @.Incorrect-Procedure-Arity (@.wrong-arity proc +4 (list.size args)))))) (def: (java-type-to-parameter type) - (-> java.lang.reflect.Type (Meta Text)) - (cond (host;instance? Class type) - (macro/wrap (Class.getName [] (:! Class type))) + (-> java/lang/reflect/Type (Meta Text)) + (cond (host.instance? Class type) + (macro/wrap (Class::getName [] (:! Class type))) - (host;instance? ParameterizedType type) - (java-type-to-parameter (ParameterizedType.getRawType [] (:! ParameterizedType type))) + (host.instance? ParameterizedType type) + (java-type-to-parameter (ParameterizedType::getRawType [] (:! ParameterizedType type))) - (or (host;instance? TypeVariable type) - (host;instance? WildcardType type)) + (or (host.instance? TypeVariable type) + (host.instance? WildcardType type)) (macro/wrap "java.lang.Object") - (host;instance? GenericArrayType type) - (do macro;Monad<Meta> - [componentP (java-type-to-parameter (GenericArrayType.getGenericComponentType [] (:! GenericArrayType type)))] + (host.instance? GenericArrayType type) + (do macro.Monad<Meta> + [componentP (java-type-to-parameter (GenericArrayType::getGenericComponentType [] (:! GenericArrayType type)))] (wrap (format componentP "[]"))) ## else - (&;throw Cannot-Convert-To-Parameter (type-descriptor type)))) + (&.throw Cannot-Convert-To-Parameter (type-descriptor type)))) (type: Method-Type #Static @@ -917,326 +917,326 @@ (def: (check-method class method-name method-type arg-classes method) (-> (Class Object) Text Method-Type (List Text) Method (Meta Bool)) - (do macro;Monad<Meta> - [parameters (|> (Method.getGenericParameterTypes [] method) - array;to-list - (monad;map @ java-type-to-parameter)) - #let [modifiers (Method.getModifiers [] method)]] - (wrap (and (Object.equals [class] (Method.getDeclaringClass [] method)) - (text/= method-name (Method.getName [] method)) + (do macro.Monad<Meta> + [parameters (|> (Method::getGenericParameterTypes [] method) + array.to-list + (monad.map @ java-type-to-parameter)) + #let [modifiers (Method::getModifiers [] method)]] + (wrap (and (Object::equals [class] (Method::getDeclaringClass [] method)) + (text/= method-name (Method::getName [] method)) (case #Static #Special - (Modifier.isStatic [modifiers]) + (Modifier::isStatic [modifiers]) _ true) (case method-type #Special - (not (or (Modifier.isInterface [(Class.getModifiers [] class)]) - (Modifier.isAbstract [modifiers]))) + (not (or (Modifier::isInterface [(Class::getModifiers [] class)]) + (Modifier::isAbstract [modifiers]))) _ true) - (n.= (list;size arg-classes) (list;size parameters)) + (n/= (list.size arg-classes) (list.size parameters)) (list/fold (function [[expectedJC actualJC] prev] (and prev (text/= expectedJC actualJC))) true - (list;zip2 arg-classes parameters)))))) + (list.zip2 arg-classes parameters)))))) (def: (check-constructor class arg-classes constructor) (-> (Class Object) (List Text) (Constructor Object) (Meta Bool)) - (do macro;Monad<Meta> - [parameters (|> (Constructor.getGenericParameterTypes [] constructor) - array;to-list - (monad;map @ java-type-to-parameter))] - (wrap (and (Object.equals [class] (Constructor.getDeclaringClass [] constructor)) - (n.= (list;size arg-classes) (list;size parameters)) + (do macro.Monad<Meta> + [parameters (|> (Constructor::getGenericParameterTypes [] constructor) + array.to-list + (monad.map @ java-type-to-parameter))] + (wrap (and (Object::equals [class] (Constructor::getDeclaringClass [] constructor)) + (n/= (list.size arg-classes) (list.size parameters)) (list/fold (function [[expectedJC actualJC] prev] (and prev (text/= expectedJC actualJC))) true - (list;zip2 arg-classes parameters)))))) + (list.zip2 arg-classes parameters)))))) (def: idx-to-bound (-> Nat Type) - (|>. (n.* +2) n.inc #;Bound)) + (|>> (n/* +2) n/inc #.Bound)) (def: (type-vars amount offset) (-> Nat Nat (List Type)) - (if (n.= +0 amount) + (if (n/= +0 amount) (list) - (|> (list;n.range offset (|> amount n.dec (n.+ offset))) + (|> (list.n/range offset (|> amount n/dec (n/+ offset))) (list/map idx-to-bound)))) (def: (method-to-type method-type method) (-> Method-Type Method (Meta [Type (List Type)])) - (let [owner (Method.getDeclaringClass [] method) - owner-name (Class.getName [] owner) + (let [owner (Method::getDeclaringClass [] method) + owner-name (Class::getName [] owner) owner-tvars (case method-type #Static (list) _ - (|> (Class.getTypeParameters [] owner) - array;to-list - (list/map (TypeVariable.getName [])))) - method-tvars (|> (Method.getTypeParameters [] method) - array;to-list - (list/map (TypeVariable.getName []))) - num-owner-tvars (list;size owner-tvars) - num-method-tvars (list;size method-tvars) + (|> (Class::getTypeParameters [] owner) + array.to-list + (list/map (TypeVariable::getName [])))) + method-tvars (|> (Method::getTypeParameters [] method) + array.to-list + (list/map (TypeVariable::getName []))) + num-owner-tvars (list.size owner-tvars) + num-method-tvars (list.size method-tvars) all-tvars (list/compose owner-tvars method-tvars) - num-all-tvars (list;size all-tvars) + num-all-tvars (list.size all-tvars) owner-tvarsT (type-vars num-owner-tvars +0) method-tvarsT (type-vars num-method-tvars num-owner-tvars) mappings (: Mappings - (if (list;empty? all-tvars) + (if (list.empty? all-tvars) fresh-mappings (|> (list/compose owner-tvarsT method-tvarsT) - list;reverse - (list;zip2 all-tvars) - (dict;from-list text;Hash<Text>))))] - (do macro;Monad<Meta> - [inputsT (|> (Method.getGenericParameterTypes [] method) - array;to-list - (monad;map @ (java-type-to-lux-type mappings))) - outputT (java-type-to-lux-type mappings (Method.getGenericReturnType [] method)) - exceptionsT (|> (Method.getGenericExceptionTypes [] method) - array;to-list - (monad;map @ (java-type-to-lux-type mappings))) - #let [methodT (<| (type;univ-q num-all-tvars) - (type;function (case method-type + list.reverse + (list.zip2 all-tvars) + (dict.from-list text.Hash<Text>))))] + (do macro.Monad<Meta> + [inputsT (|> (Method::getGenericParameterTypes [] method) + array.to-list + (monad.map @ (java-type-to-lux-type mappings))) + outputT (java-type-to-lux-type mappings (Method::getGenericReturnType [] method)) + exceptionsT (|> (Method::getGenericExceptionTypes [] method) + array.to-list + (monad.map @ (java-type-to-lux-type mappings))) + #let [methodT (<| (type.univ-q num-all-tvars) + (type.function (case method-type #Static inputsT _ - (list& (#;Primitive owner-name (list;reverse owner-tvarsT)) + (list& (#.Primitive owner-name (list.reverse owner-tvarsT)) inputsT))) outputT)]] (wrap [methodT exceptionsT])))) (def: (methods class-name method-name method-type arg-classes) (-> Text Text Method-Type (List Text) (Meta [Type (List Type)])) - (do macro;Monad<Meta> + (do macro.Monad<Meta> [class (load-class class-name) candidates (|> class - (Class.getDeclaredMethods []) - array;to-list - (monad;map @ (function [method] + (Class::getDeclaredMethods []) + array.to-list + (monad.map @ (function [method] (do @ [passes? (check-method class method-name method-type arg-classes method)] (wrap [passes? method])))))] - (case (list;filter product;left candidates) - #;Nil - (&;throw No-Candidates (format class-name "#" method-name)) + (case (list.filter product.left candidates) + #.Nil + (&.throw No-Candidates (format class-name "#" method-name)) - (#;Cons candidate #;Nil) - (|> candidate product;right (method-to-type method-type)) + (#.Cons candidate #.Nil) + (|> candidate product.right (method-to-type method-type)) _ - (&;throw Too-Many-Candidates (format class-name "#" method-name))))) + (&.throw Too-Many-Candidates (format class-name "#" method-name))))) (def: (constructor-to-type constructor) (-> (Constructor Object) (Meta [Type (List Type)])) - (let [owner (Constructor.getDeclaringClass [] constructor) - owner-name (Class.getName [] owner) - owner-tvars (|> (Class.getTypeParameters [] owner) - array;to-list - (list/map (TypeVariable.getName []))) - constructor-tvars (|> (Constructor.getTypeParameters [] constructor) - array;to-list - (list/map (TypeVariable.getName []))) - num-owner-tvars (list;size owner-tvars) + (let [owner (Constructor::getDeclaringClass [] constructor) + owner-name (Class::getName [] owner) + owner-tvars (|> (Class::getTypeParameters [] owner) + array.to-list + (list/map (TypeVariable::getName []))) + constructor-tvars (|> (Constructor::getTypeParameters [] constructor) + array.to-list + (list/map (TypeVariable::getName []))) + num-owner-tvars (list.size owner-tvars) all-tvars (list/compose owner-tvars constructor-tvars) - num-all-tvars (list;size all-tvars) + num-all-tvars (list.size all-tvars) owner-tvarsT (type-vars num-owner-tvars +0) constructor-tvarsT (type-vars num-all-tvars num-owner-tvars) mappings (: Mappings - (if (list;empty? all-tvars) + (if (list.empty? all-tvars) fresh-mappings (|> (list/compose owner-tvarsT constructor-tvarsT) - list;reverse - (list;zip2 all-tvars) - (dict;from-list text;Hash<Text>))))] - (do macro;Monad<Meta> - [inputsT (|> (Constructor.getGenericParameterTypes [] constructor) - array;to-list - (monad;map @ (java-type-to-lux-type mappings))) - exceptionsT (|> (Constructor.getGenericExceptionTypes [] constructor) - array;to-list - (monad;map @ (java-type-to-lux-type mappings))) - #let [objectT (#;Primitive owner-name (list;reverse owner-tvarsT)) - constructorT (<| (type;univ-q num-all-tvars) - (type;function inputsT) + list.reverse + (list.zip2 all-tvars) + (dict.from-list text.Hash<Text>))))] + (do macro.Monad<Meta> + [inputsT (|> (Constructor::getGenericParameterTypes [] constructor) + array.to-list + (monad.map @ (java-type-to-lux-type mappings))) + exceptionsT (|> (Constructor::getGenericExceptionTypes [] constructor) + array.to-list + (monad.map @ (java-type-to-lux-type mappings))) + #let [objectT (#.Primitive owner-name (list.reverse owner-tvarsT)) + constructorT (<| (type.univ-q num-all-tvars) + (type.function inputsT) objectT)]] (wrap [constructorT exceptionsT])))) (def: (constructor-methods class-name arg-classes) (-> Text (List Text) (Meta [Type (List Type)])) - (do macro;Monad<Meta> + (do macro.Monad<Meta> [class (load-class class-name) candidates (|> class - (Class.getConstructors []) - array;to-list - (monad;map @ (function [constructor] + (Class::getConstructors []) + array.to-list + (monad.map @ (function [constructor] (do @ [passes? (check-constructor class arg-classes constructor)] (wrap [passes? constructor])))))] - (case (list;filter product;left candidates) - #;Nil - (&;throw No-Candidates (format class-name "(" (text;join-with ", " arg-classes) ")")) + (case (list.filter product.left candidates) + #.Nil + (&.throw No-Candidates (format class-name "(" (text.join-with ", " arg-classes) ")")) - (#;Cons candidate #;Nil) - (|> candidate product;right constructor-to-type) + (#.Cons candidate #.Nil) + (|> candidate product.right constructor-to-type) _ - (&;throw Too-Many-Candidates class-name)))) + (&.throw Too-Many-Candidates class-name)))) (def: (decorate-inputs typesT inputsA) - (-> (List Text) (List la;Analysis) (List la;Analysis)) + (-> (List Text) (List la.Analysis) (List la.Analysis)) (|> inputsA - (list;zip2 (list/map code;text typesT)) + (list.zip2 (list/map code.text typesT)) (list/map (function [[type value]] - (la;product (list type value)))))) + (la.product (list type value)))))) (def: (sub-type-analyser analyse) - (-> &;Analyser &;Analyser) + (-> &.Analyser &.Analyser) (function [argC] - (do macro;Monad<Meta> - [[argT argA] (&common;with-unknown-type + (do macro.Monad<Meta> + [[argT argA] (&common.with-unknown-type (analyse argC)) - expectedT macro;expected-type + expectedT macro.expected-type [unboxed castT] (cast #In expectedT argT)] (wrap argA)))) (def: (invoke//static proc) - (-> Text @;Proc) + (-> Text @.Proc) (function [analyse eval 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> - [#let [argsT (list/map product;left argsTC)] + (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> + [#let [argsT (list/map product.left argsTC)] [methodT exceptionsT] (methods class method #Static argsT) - [outputT argsA] (inferenceA;general (sub-type-analyser analyse) methodT (list/map product;right argsTC)) + [outputT argsA] (inferenceA.general (sub-type-analyser analyse) methodT (list/map product.right argsTC)) [unboxed castT] (infer-out outputT)] - (wrap (la;procedure proc (list& (code;text class) (code;text method) - (code;text unboxed) (decorate-inputs argsT argsA))))) + (wrap (la.procedure proc (list& (code.text class) (code.text method) + (code.text unboxed) (decorate-inputs argsT argsA))))) _ - (&;throw Wrong-Syntax (wrong-syntax proc args))))) + (&.throw Wrong-Syntax (wrong-syntax proc args))))) (def: (invoke//virtual proc) - (-> Text @;Proc) + (-> Text @.Proc) (function [analyse eval 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> - [#let [argsT (list/map product;left argsTC)] + (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> + [#let [argsT (list/map product.left argsTC)] [methodT exceptionsT] (methods class method #Virtual argsT) - [outputT allA] (inferenceA;general (sub-type-analyser analyse) methodT (list& objectC (list/map product;right argsTC))) + [outputT allA] (inferenceA.general (sub-type-analyser analyse) methodT (list& objectC (list/map product.right argsTC))) #let [[objectA argsA] (case allA - (#;Cons objectA argsA) + (#.Cons objectA argsA) [objectA argsA] _ (undefined))] [unboxed castT] (infer-out outputT)] - (wrap (la;procedure proc (list& (code;text class) (code;text method) - (code;text unboxed) objectA (decorate-inputs argsT argsA))))) + (wrap (la.procedure proc (list& (code.text class) (code.text method) + (code.text unboxed) objectA (decorate-inputs argsT argsA))))) _ - (&;throw Wrong-Syntax (wrong-syntax proc args))))) + (&.throw Wrong-Syntax (wrong-syntax proc args))))) (def: (invoke//special proc) - (-> Text @;Proc) + (-> Text @.Proc) (function [analyse eval args] - (case (: (e;Error [(List Code) [Text Text Code (List [Text Code]) Unit]]) - (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> - [#let [argsT (list/map product;left argsTC)] + (case (: (e.Error [(List Code) [Text Text Code (List [Text Code]) Unit]]) + (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> + [#let [argsT (list/map product.left argsTC)] [methodT exceptionsT] (methods class method #Special argsT) - [outputT argsA] (inferenceA;general (sub-type-analyser analyse) methodT (list& objectC (list/map product;right argsTC))) + [outputT argsA] (inferenceA.general (sub-type-analyser analyse) methodT (list& objectC (list/map product.right argsTC))) [unboxed castT] (infer-out outputT)] - (wrap (la;procedure proc (list& (code;text class) (code;text method) - (code;text unboxed) (decorate-inputs argsT argsA))))) + (wrap (la.procedure proc (list& (code.text class) (code.text method) + (code.text unboxed) (decorate-inputs argsT argsA))))) _ - (&;throw Wrong-Syntax (wrong-syntax proc args))))) + (&.throw Wrong-Syntax (wrong-syntax proc args))))) (def: (invoke//interface proc) - (-> Text @;Proc) + (-> Text @.Proc) (function [analyse eval 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> - [#let [argsT (list/map product;left argsTC)] + (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> + [#let [argsT (list/map product.left argsTC)] class (load-class class-name) - _ (&;assert Non-Interface class-name - (Modifier.isInterface [(Class.getModifiers [] class)])) + _ (&.assert Non-Interface class-name + (Modifier::isInterface [(Class::getModifiers [] class)])) [methodT exceptionsT] (methods class-name method #Interface argsT) - [outputT argsA] (inferenceA;general (sub-type-analyser analyse) methodT (list& objectC (list/map product;right argsTC))) + [outputT argsA] (inferenceA.general (sub-type-analyser analyse) methodT (list& objectC (list/map product.right argsTC))) [unboxed castT] (infer-out outputT)] - (wrap (la;procedure proc - (list& (code;text class-name) (code;text method) (code;text unboxed) + (wrap (la.procedure proc + (list& (code.text class-name) (code.text method) (code.text unboxed) (decorate-inputs argsT argsA))))) _ - (&;throw Wrong-Syntax (wrong-syntax proc args))))) + (&.throw Wrong-Syntax (wrong-syntax proc args))))) (def: (invoke//constructor proc) - (-> Text @;Proc) + (-> Text @.Proc) (function [analyse eval 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> - [#let [argsT (list/map product;left argsTC)] + (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> + [#let [argsT (list/map product.left argsTC)] [methodT exceptionsT] (constructor-methods class argsT) - [outputT argsA] (inferenceA;general (sub-type-analyser analyse) methodT (list/map product;right argsTC)) + [outputT argsA] (inferenceA.general (sub-type-analyser analyse) methodT (list/map product.right argsTC)) [unboxed castT] (infer-out outputT)] - (wrap (la;procedure proc (list& (code;text class) (decorate-inputs argsT argsA))))) + (wrap (la.procedure proc (list& (code.text class) (decorate-inputs argsT argsA))))) _ - (&;throw Wrong-Syntax (wrong-syntax proc args))))) + (&.throw Wrong-Syntax (wrong-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) + @.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) ))) ))) (def: #export procedures - @;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) + @.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) ))) |