From 901b09dada43ec6f3b21618800ec7400fda54a0d Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Wed, 18 Oct 2017 12:42:46 -0400 Subject: - Updated to the latest changes in stdlib. --- .../source/luxc/analyser/procedure/host.jvm.lux | 212 ++++++++++----------- 1 file changed, 106 insertions(+), 106 deletions(-) (limited to 'new-luxc/source/luxc/analyser/procedure/host.jvm.lux') diff --git a/new-luxc/source/luxc/analyser/procedure/host.jvm.lux b/new-luxc/source/luxc/analyser/procedure/host.jvm.lux index ca4eb762f..ff4f0f3d6 100644 --- a/new-luxc/source/luxc/analyser/procedure/host.jvm.lux +++ b/new-luxc/source/luxc/analyser/procedure/host.jvm.lux @@ -4,7 +4,7 @@ ["p" parser] ["ex" exception #+ exception:]) (concurrency ["A" atom]) - (data ["R" result] + (data ["e" error] [maybe] [product] [bool "bool/" Eq] @@ -12,12 +12,12 @@ (text format ["l" lexer]) (coll [list "list/" Fold Functor Monoid] - [array #+ Array] + [array] [dict #+ Dict])) - [macro "lux/" Monad] - (macro ["s" syntax]) - [type] - (type ["tc" check]) + [meta "meta/" Monad] + (meta ["s" syntax] + [type] + (type ["tc" check])) [host]) (luxc ["&" base] ["&;" host] @@ -152,7 +152,7 @@ (function [[var-id varT]] (case args (^ (list arrayC)) - (do macro;Monad + (do meta;Monad [arrayA (&;with-expected-type (type (Array varT)) (analyse arrayC)) _ (&;infer Nat)] @@ -170,11 +170,11 @@ (function [analyse args] (case args (^ (list lengthC)) - (do macro;Monad + (do meta;Monad [lengthA (&;with-expected-type Nat (analyse lengthC)) - expectedT macro;expected-type - [level elem-class] (: (Lux [Nat Text]) + expectedT meta;expected-type + [level elem-class] (: (Meta [Nat Text]) (loop [analysisT expectedT level +0] (case analysisT @@ -206,10 +206,10 @@ (format "Non-object type: " (%type type))) (def: (check-jvm objectT) - (-> Type (Lux Text)) + (-> Type (Meta Text)) (case objectT (#;Host name _) - (lux/wrap name) + (meta/wrap name) (#;Named name unnamed) (check-jvm unnamed) @@ -232,16 +232,16 @@ (&;fail (not-object objectT)))) (def: (check-object objectT) - (-> Type (Lux Text)) - (do macro;Monad + (-> Type (Meta Text)) + (do meta;Monad [name (check-jvm objectT)] (if (dict;contains? name boxes) (&;fail (format "Primitives are not objects: " name)) - (:: macro;Monad wrap name)))) + (:: meta;Monad wrap name)))) (def: (box-array-element-type elemT) - (-> Type (Lux [Type Text])) - (do macro;Monad + (-> Type (Meta [Type Text])) + (do meta;Monad [] (case elemT (#;Host name #;Nil) @@ -253,7 +253,7 @@ (#;Host name _) (if (dict;contains? name boxes) (&;fail (format "Primitives cannot be parameterized: " name)) - (:: macro;Monad wrap [elemT name])) + (:: meta;Monad wrap [elemT name])) _ (&;fail (format "Invalid type for array element: " (%type elemT)))))) @@ -265,7 +265,7 @@ (function [[var-id varT]] (case args (^ (list arrayC idxC)) - (do macro;Monad + (do meta;Monad [arrayA (&;with-expected-type (type (Array varT)) (analyse arrayC)) elemT (&;with-type-env @@ -286,7 +286,7 @@ (function [[var-id varT]] (case args (^ (list arrayC idxC valueC)) - (do macro;Monad + (do meta;Monad [arrayA (&;with-expected-type (type (Array varT)) (analyse arrayC)) elemT (&;with-type-env @@ -317,8 +317,8 @@ (function [analyse args] (case args (^ (list)) - (do macro;Monad - [expectedT macro;expected-type + (do meta;Monad + [expectedT meta;expected-type _ (check-object expectedT)] (wrap (#la;Procedure proc (list)))) @@ -332,7 +332,7 @@ (function [[var-id varT]] (case args (^ (list objectC)) - (do macro;Monad + (do meta;Monad [objectA (&;with-expected-type varT (analyse objectC)) objectT (&;with-type-env @@ -351,7 +351,7 @@ (function [[var-id varT]] (case args (^ (list monitorC exprC)) - (do macro;Monad + (do meta;Monad [monitorA (&;with-expected-type varT (analyse monitorC)) monitorT (&;with-type-env @@ -426,19 +426,19 @@ (getDeclaredMethods [] (Array Method))) (def: (load-class name) - (-> Text (Lux (Class Object))) - (do macro;Monad + (-> Text (Meta (Class Object))) + (do meta;Monad [class-loader &host;class-loader] (case (Class.forName [name false class-loader]) - (#R;Success [class]) + (#e;Success [class]) (wrap class) - (#R;Error error) + (#e;Error error) (&;fail (format "Unknown class: " name))))) (def: (sub-class? super sub) - (-> Text Text (Lux Bool)) - (do macro;Monad + (-> Text Text (Meta Bool)) + (do meta;Monad [super (load-class super) sub (load-class sub)] (wrap (Class.isAssignableFrom [sub] super)))) @@ -452,14 +452,14 @@ (function [[var-id varT]] (case args (^ (list exceptionC)) - (do macro;Monad + (do meta;Monad [exceptionA (&;with-expected-type varT (analyse exceptionC)) exceptionT (&;with-type-env (tc;read var-id)) exception-class (check-object exceptionT) ? (sub-class? "java.lang.Throwable" exception-class) - _ (: (Lux Unit) + _ (: (Meta Unit) (if ? (wrap []) (&;throw Not-Throwable exception-class))) @@ -476,7 +476,7 @@ (^ (list classC)) (case classC [_ (#;Text class)] - (do macro;Monad + (do meta;Monad [_ (load-class class) _ (&;infer (#;Host "java.lang.Class" (list (#;Host class (list)))))] (wrap (#la;Procedure proc (list (#la;Text class))))) @@ -498,7 +498,7 @@ (^ (list classC objectC)) (case classC [_ (#;Text class)] - (do macro;Monad + (do meta;Monad [objectA (&;with-expected-type varT (analyse objectC)) objectT (&;with-type-env @@ -542,9 +542,9 @@ (java.lang.reflect.Type.getTypeName [])) (def: (java-type-to-class type) - (-> java.lang.reflect.Type (Lux Text)) + (-> java.lang.reflect.Type (Meta Text)) (cond (host;instance? Class type) - (lux/wrap (Class.getName [] (:! Class type))) + (meta/wrap (Class.getName [] (:! Class type))) (host;instance? ParameterizedType type) (java-type-to-class (ParameterizedType.getRawType [] (:! ParameterizedType type))) @@ -560,55 +560,55 @@ (def: fresh-mappings Mappings (dict;new text;Hash)) (def: (java-type-to-lux-type mappings java-type) - (-> Mappings java.lang.reflect.Type (Lux 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) - (lux/wrap var-type) + (meta/wrap var-type) #;None (&;throw Unknown-Type-Var var-name))) (host;instance? WildcardType java-type) (let [java-type (:! WildcardType java-type)] - (case [(array;get +0 (WildcardType.getUpperBounds [] java-type)) - (array;get +0 (WildcardType.getLowerBounds [] java-type))] + (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) _ - (lux/wrap Top))) + (meta/wrap Top))) (host;instance? Class java-type) (let [java-type (:! (Class Object) java-type) class-name (Class.getName [] java-type)] - (lux/wrap (case (array;size (Class.getTypeParameters [] java-type)) - +0 - (#;Host class-name (list)) - - arity - (|> (list;n.range +0 (n.dec arity)) - list;reverse - (list/map (|>. (n.* +2) n.inc #;Bound)) - (#;Host class-name) - (type;univ-q arity))))) + (meta/wrap (case (array;size (Class.getTypeParameters [] java-type)) + +0 + (#;Host class-name (list)) + + arity + (|> (list;n.range +0 (n.dec arity)) + list;reverse + (list/map (|>. (n.* +2) n.inc #;Bound)) + (#;Host class-name) + (type;univ-q arity))))) (host;instance? ParameterizedType java-type) (let [java-type (:! ParameterizedType java-type) raw (ParameterizedType.getRawType [] java-type)] (if (host;instance? Class raw) - (do macro;Monad + (do meta;Monad [paramsT (|> java-type (ParameterizedType.getActualTypeArguments []) array;to-list (monad;map @ (java-type-to-lux-type mappings)))] - (lux/wrap (#;Host (Class.getName [] (:! (Class Object) raw)) - paramsT))) + (meta/wrap (#;Host (Class.getName [] (:! (Class Object) raw)) + paramsT))) (&;throw JVM-Type-Is-Not-Class (type-descriptor raw)))) (host;instance? GenericArrayType java-type) - (do macro;Monad + (do meta;Monad [innerT (|> (:! GenericArrayType java-type) (GenericArrayType.getGenericComponentType []) (java-type-to-lux-type mappings))] @@ -628,8 +628,8 @@ #Out from)) (def: (cast direction to from) - (-> Direction Type Type (Lux [Text Type])) - (do macro;Monad + (-> Direction Type Type (Meta [Text Type])) + (do meta;Monad [to-name (check-jvm to) from-name (check-jvm from)] (cond (dict;contains? to-name boxes) @@ -677,23 +677,23 @@ (&;fail (format "No valid path between " (%type from) "and " (%type to) "."))))))) (def: (find-field class-name field-name) - (-> Text Text (Lux [(Class Object) Field])) - (do macro;Monad + (-> Text Text (Meta [(Class Object) Field])) + (do meta;Monad [class (load-class class-name)] (case (Class.getDeclaredField [field-name] class) - (#R;Success field) + (#e;Success field) (let [owner (Field.getDeclaringClass [] field)] (if (is owner class) (wrap [class field]) (&;fail (format "Field '" field-name "' does not belong to class '" class-name "'.\n" "Belongs to '" (Class.getName [] owner) "'.")))) - (#R;Error _) + (#e;Error _) (&;fail (format "Unknown field '" field-name "' for class '" class-name "'."))))) (def: (static-field class-name field-name) - (-> Text Text (Lux [Type Bool])) - (do macro;Monad + (-> Text Text (Meta [Type Bool])) + (do meta;Monad [[class fieldJ] (find-field class-name field-name) #let [modifiers (Field.getModifiers [] fieldJ)]] (if (Modifier.isStatic [modifiers]) @@ -706,8 +706,8 @@ (exception: #export Non-Object-Type) (def: (virtual-field class-name field-name objectT) - (-> Text Text Type (Lux [Type Bool])) - (do macro;Monad + (-> Text Text Type (Meta [Type Bool])) + (do meta;Monad [[class fieldJ] (find-field class-name field-name) #let [modifiers (Field.getModifiers [] fieldJ)]] (if (not (Modifier.isStatic [modifiers])) @@ -717,7 +717,7 @@ (Class.getTypeParameters []) array;to-list (list/map (TypeVariable.getName [])))] - mappings (: (Lux Mappings) + mappings (: (Meta Mappings) (case objectT (#;Host _class-name _class-params) (do @ @@ -735,9 +735,9 @@ (&;fail (format "Field '" field-name "' of class '" class-name "' is static."))))) (def: (analyse-object class analyse sourceC) - (-> Text &;Analyser Code (Lux [Type la;Analysis])) + (-> Text &;Analyser Code (Meta [Type la;Analysis])) (<| &common;with-var (function [[var-id varT]]) - (do macro;Monad + (do meta;Monad [target-class (load-class class) targetT (java-type-to-lux-type fresh-mappings (:! java.lang.reflect.Type @@ -752,9 +752,9 @@ (wrap [castT sourceA])))) (def: (analyse-input analyse targetT sourceC) - (-> &;Analyser Type Code (Lux [Type Text la;Analysis])) + (-> &;Analyser Type Code (Meta [Type Text la;Analysis])) (<| &common;with-var (function [[var-id varT]]) - (do macro;Monad + (do meta;Monad [sourceA (&;with-expected-type varT (analyse sourceC)) sourceT (&;with-type-env @@ -769,9 +769,9 @@ (^ (list classC fieldC)) (case [classC fieldC] [[_ (#;Text class)] [_ (#;Text field)]] - (do macro;Monad + (do meta;Monad [[fieldT final?] (static-field class field) - expectedT macro;expected-type + expectedT meta;expected-type [unboxed castT] (cast #Out expectedT fieldT) _ (&;with-type-env (tc;check expectedT castT))] @@ -790,7 +790,7 @@ (^ (list classC fieldC valueC)) (case [classC fieldC] [[_ (#;Text class)] [_ (#;Text field)]] - (do macro;Monad + (do meta;Monad [[fieldT final?] (static-field class field) _ (&;assert (Final-Field (format class "#" field)) (not final?)) @@ -813,10 +813,10 @@ (^ (list classC fieldC objectC)) (case [classC fieldC] [[_ (#;Text class)] [_ (#;Text field)]] - (do macro;Monad + (do meta;Monad [[objectT objectA] (analyse-object class analyse objectC) [fieldT final?] (virtual-field class field objectT) - expectedT macro;expected-type + expectedT meta;expected-type [unboxed castT] (cast #Out expectedT fieldT) _ (&;with-type-env (tc;check expectedT castT))] @@ -835,7 +835,7 @@ (^ (list classC fieldC valueC objectC)) (case [classC fieldC] [[_ (#;Text class)] [_ (#;Text field)]] - (do macro;Monad + (do meta;Monad [[objectT objectA] (analyse-object class analyse objectC) [fieldT final?] (virtual-field class field objectT) _ (&;assert (Final-Field (format class "#" field)) @@ -853,16 +853,16 @@ (&;fail (@;wrong-arity proc +4 (list;size args)))))) (def: (java-type-to-parameter type) - (-> java.lang.reflect.Type (Lux Text)) + (-> java.lang.reflect.Type (Meta Text)) (cond (host;instance? Class type) - (lux/wrap (Class.getName [] (:! Class type))) + (meta/wrap (Class.getName [] (:! Class type))) (host;instance? ParameterizedType type) (java-type-to-parameter (ParameterizedType.getRawType [] (:! ParameterizedType type))) (or (host;instance? TypeVariable type) (host;instance? WildcardType type)) - (lux/wrap "java.lang.Object") + (meta/wrap "java.lang.Object") ## else (&;throw Cannot-Convert-To-Parameter (type-descriptor type)))) @@ -875,8 +875,8 @@ #Interface) (def: (check-method class method-name method-type arg-classes method) - (-> (Class Object) Text Method-Type (List Text) Method (Lux Bool)) - (do macro;Monad + (-> (Class Object) Text Method-Type (List Text) Method (Meta Bool)) + (do meta;Monad [parameters (|> (Method.getGenericParameterTypes [] method) array;to-list (monad;map @ java-type-to-parameter)) @@ -904,8 +904,8 @@ (list;zip2 arg-classes parameters)))))) (def: (check-constructor class arg-classes constructor) - (-> (Class Object) (List Text) (Constructor Object) (Lux Bool)) - (do macro;Monad + (-> (Class Object) (List Text) (Constructor Object) (Meta Bool)) + (do meta;Monad [parameters (|> (Constructor.getGenericParameterTypes [] constructor) array;to-list (monad;map @ java-type-to-parameter))] @@ -922,7 +922,7 @@ (|>. (n.* +2) n.inc #;Bound)) (def: (method-to-type method-type method) - (-> Method-Type Method (Lux [Type (List Type)])) + (-> Method-Type Method (Meta [Type (List Type)])) (let [owner (Method.getDeclaringClass [] method) owner-name (Class.getName [] owner) owner-tvars (case method-type @@ -948,7 +948,7 @@ list;reverse (list;zip2 all-tvars) (dict;from-list text;Hash))))] - (do macro;Monad + (do meta;Monad [inputsT (|> (Method.getGenericParameterTypes [] method) array;to-list (monad;map @ (java-type-to-lux-type fresh-mappings))) @@ -971,8 +971,8 @@ (exception: #export Too-Many-Candidate-Methods) (def: (methods class-name method-name method-type arg-classes) - (-> Text Text Method-Type (List Text) (Lux [Type (List Type)])) - (do macro;Monad + (-> Text Text Method-Type (List Text) (Meta [Type (List Type)])) + (do meta;Monad [class (load-class class-name) candidates (|> class (Class.getDeclaredMethods []) @@ -992,7 +992,7 @@ (&;throw Too-Many-Candidate-Methods (format class-name "#" method-name))))) (def: (constructor-to-type constructor) - (-> (Constructor Object) (Lux [Type (List Type)])) + (-> (Constructor Object) (Meta [Type (List Type)])) (let [owner (Constructor.getDeclaringClass [] constructor) owner-name (Class.getName [] owner) owner-tvars (|> (Class.getTypeParameters [] owner) @@ -1013,7 +1013,7 @@ list;reverse (list;zip2 all-tvars) (dict;from-list text;Hash))))] - (do macro;Monad + (do meta;Monad [inputsT (|> (Constructor.getGenericParameterTypes [] constructor) array;to-list (monad;map @ (java-type-to-lux-type fresh-mappings))) @@ -1030,8 +1030,8 @@ (exception: #export Too-Many-Candidate-Constructors) (def: (constructor-methods class-name arg-classes) - (-> Text (List Text) (Lux [Type (List Type)])) - (do macro;Monad + (-> Text (List Text) (Meta [Type (List Type)])) + (do meta;Monad [class (load-class class-name) candidates (|> class (Class.getConstructors []) @@ -1053,10 +1053,10 @@ (def: (invoke//static proc) (-> Text @;Proc) (function [analyse args] - (case (: (R;Result [(List Code) [Text Text (List [Text Code]) Unit]]) + (case (: (e;Error [(List Code) [Text Text (List [Text Code]) Unit]]) (p;run args ($_ p;seq s;text s;text (p;some (s;tuple (p;seq s;text s;any))) s;end!))) - (#R;Success [_ [class method argsTC _]]) - (do macro;Monad + (#e;Success [_ [class method argsTC _]]) + (do meta;Monad [[methodT exceptionsT] (methods class method #Static (list/map product;left argsTC)) [outputT argsA] (&inference;apply-function analyse methodT (list/map product;right argsTC)) _ (&;infer outputT)] @@ -1068,10 +1068,10 @@ (def: (invoke//virtual proc) (-> Text @;Proc) (function [analyse args] - (case (: (R;Result [(List Code) [Text Text Code (List [Text Code]) Unit]]) + (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!))) - (#R;Success [_ [class method objectC argsTC _]]) - (do macro;Monad + (#e;Success [_ [class method objectC argsTC _]]) + (do meta;Monad [[methodT exceptionsT] (methods class method #Virtual (list/map product;left argsTC)) [outputT argsA] (&inference;apply-function analyse methodT (list& objectC (list/map product;right argsTC))) _ (&;infer outputT)] @@ -1083,10 +1083,10 @@ (def: (invoke//special proc) (-> Text @;Proc) (function [analyse args] - (case (: (R;Result [(List Code) [Text Text Code (List [Text Code]) Unit]]) + (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!))) - (#R;Success [_ [class method objectC argsTC _]]) - (do macro;Monad + (#e;Success [_ [class method objectC argsTC _]]) + (do meta;Monad [[methodT exceptionsT] (methods class method #Special (list/map product;left argsTC)) [outputT argsA] (&inference;apply-function analyse methodT (list& objectC (list/map product;right argsTC))) _ (&;infer outputT)] @@ -1100,10 +1100,10 @@ (def: (invoke//interface proc) (-> Text @;Proc) (function [analyse args] - (case (: (R;Result [(List Code) [Text Text Code (List [Text Code]) Unit]]) + (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!))) - (#R;Success [_ [class-name method objectC argsTC _]]) - (do macro;Monad + (#e;Success [_ [class-name method objectC argsTC _]]) + (do meta;Monad [class (load-class class-name) _ (&;assert (Not-Interface class-name) (Modifier.isInterface [(Class.getModifiers [] class)])) @@ -1118,10 +1118,10 @@ (def: (invoke//constructor proc) (-> Text @;Proc) (function [analyse args] - (case (: (R;Result [(List Code) [Text (List [Text Code]) Unit]]) + (case (: (e;Error [(List Code) [Text (List [Text Code]) Unit]]) (p;run args ($_ p;seq s;text (p;some (s;tuple (p;seq s;text s;any))) s;end!))) - (#R;Success [_ [class argsTC _]]) - (do macro;Monad + (#e;Success [_ [class argsTC _]]) + (do meta;Monad [[methodT exceptionsT] (constructor-methods class (list/map product;left argsTC)) [outputT argsA] (&inference;apply-function analyse methodT (list/map product;right argsTC)) _ (&;infer outputT)] -- cgit v1.2.3