aboutsummaryrefslogtreecommitdiff
path: root/new-luxc/source/luxc/analyser/procedure/host.jvm.lux
diff options
context:
space:
mode:
Diffstat (limited to 'new-luxc/source/luxc/analyser/procedure/host.jvm.lux')
-rw-r--r--new-luxc/source/luxc/analyser/procedure/host.jvm.lux414
1 files changed, 360 insertions, 54 deletions
diff --git a/new-luxc/source/luxc/analyser/procedure/host.jvm.lux b/new-luxc/source/luxc/analyser/procedure/host.jvm.lux
index c75d6efd4..2a02ed6b2 100644
--- a/new-luxc/source/luxc/analyser/procedure/host.jvm.lux
+++ b/new-luxc/source/luxc/analyser/procedure/host.jvm.lux
@@ -1,16 +1,17 @@
(;module:
[lux #- char]
(lux (control [monad #+ do]
- ["p" parser])
+ ["p" parser]
+ ["ex" exception #+ exception:])
(concurrency ["A" atom])
(data ["R" result]
- [text]
+ [text "text/" Eq<Text>]
(text format
["l" lexer])
- (coll [list "list/" Fold<List>]
+ (coll [list "list/" Fold<List> Functor<List>]
[array #+ Array]
["d" dict]))
- [macro #+ Monad<Lux>]
+ [macro "lux/" Monad<Lux>]
[type]
(type ["TC" check])
[host])
@@ -147,16 +148,14 @@
(function [[var-id varT]]
(case args
(^ (list arrayC))
- (do Monad<Lux>
+ (do macro;Monad<Lux>
[arrayA (&;with-expected-type (type (Array varT))
(analyse arrayC))
- expectedT macro;expected-type
- _ (&;within-type-env
- (TC;check expectedT Nat))]
+ _ (&;infer Nat)]
(wrap (#la;Procedure proc (list arrayA))))
_
- (&;fail (@;wrong-amount-error proc +1 (list;size args))))))))
+ (&;fail (@;wrong-arity proc +1 (list;size args))))))))
(def: (invalid-array-type arrayT)
(-> Type Text)
@@ -167,7 +166,7 @@
(function [analyse args]
(case args
(^ (list lengthC))
- (do Monad<Lux>
+ (do macro;Monad<Lux>
[lengthA (&;with-expected-type Nat
(analyse lengthC))
expectedT macro;expected-type
@@ -196,7 +195,11 @@
(wrap (#la;Procedure proc (list (#la;Nat level) (#la;Text elem-class) lengthA))))
_
- (&;fail (@;wrong-amount-error proc +1 (list;size args))))))
+ (&;fail (@;wrong-arity proc +1 (list;size args))))))
+
+(def: (not-object type)
+ (-> Type Text)
+ (format "Non-object type: " (%type type)))
(def: (check-object objectT)
(-> Type (Lux Text))
@@ -204,14 +207,31 @@
(#;Host name _)
(if (d;contains? name boxes)
(&;fail (format "Primitives are not objects: " name))
- (:: Monad<Lux> wrap name))
+ (:: macro;Monad<Lux> wrap name))
+
+ (#;Named name unnamed)
+ (check-object unnamed)
+
+ (^template [<tag>]
+ (<tag> env unquantified)
+ (check-object unquantified))
+ ([#;UnivQ]
+ [#;ExQ])
+
+ (#;Apply inputT funcT)
+ (case (type;apply (list inputT) funcT)
+ (#;Some outputT)
+ (check-object outputT)
+
+ #;None
+ (&;fail (not-object objectT)))
_
- (&;fail (format "Non-object type: " (%type objectT)))))
+ (&;fail (not-object objectT))))
(def: (box-array-element-type elemT)
(-> Type (Lux [Type Text]))
- (do Monad<Lux>
+ (do macro;Monad<Lux>
[]
(case elemT
(#;Host name #;Nil)
@@ -223,7 +243,7 @@
(#;Host name _)
(if (d;contains? name boxes)
(&;fail (format "Primitives cannot be parameterized: " name))
- (:: Monad<Lux> wrap [elemT name]))
+ (:: macro;Monad<Lux> wrap [elemT name]))
_
(&;fail (format "Invalid type for array element: " (%type elemT))))))
@@ -235,7 +255,7 @@
(function [[var-id varT]]
(case args
(^ (list arrayC idxC))
- (do Monad<Lux>
+ (do macro;Monad<Lux>
[arrayA (&;with-expected-type (type (Array varT))
(analyse arrayC))
elemT (&;within-type-env
@@ -243,13 +263,11 @@
[elemT elem-class] (box-array-element-type elemT)
idxA (&;with-expected-type Nat
(analyse idxC))
- expectedT macro;expected-type
- _ (&;within-type-env
- (TC;check expectedT elemT))]
+ _ (&;infer elemT)]
(wrap (#la;Procedure proc (list (#la;Text elem-class) arrayA idxA))))
_
- (&;fail (@;wrong-amount-error proc +2 (list;size args))))))))
+ (&;fail (@;wrong-arity proc +2 (list;size args))))))))
(def: (array-write proc)
(-> Text @;Proc)
@@ -258,7 +276,7 @@
(function [[var-id varT]]
(case args
(^ (list arrayC idxC valueC))
- (do Monad<Lux>
+ (do macro;Monad<Lux>
[arrayA (&;with-expected-type (type (Array varT))
(analyse arrayC))
elemT (&;within-type-env
@@ -268,13 +286,11 @@
(analyse idxC))
valueA (&;with-expected-type valueT
(analyse valueC))
- expectedT macro;expected-type
- _ (&;within-type-env
- (TC;check expectedT (type (Array elemT))))]
+ _ (&;infer (type (Array elemT)))]
(wrap (#la;Procedure proc (list (#la;Text elem-class) arrayA idxA valueA))))
_
- (&;fail (@;wrong-amount-error proc +3 (list;size args))))))))
+ (&;fail (@;wrong-arity proc +3 (list;size args))))))))
(def: array-procs
@;Bundle
@@ -291,13 +307,13 @@
(function [analyse args]
(case args
(^ (list))
- (do Monad<Lux>
+ (do macro;Monad<Lux>
[expectedT macro;expected-type
_ (check-object expectedT)]
(wrap (#la;Procedure proc (list))))
_
- (&;fail (@;wrong-amount-error proc +0 (list;size args))))))
+ (&;fail (@;wrong-arity proc +0 (list;size args))))))
(def: (object-null? proc)
(-> Text @;Proc)
@@ -306,19 +322,17 @@
(function [[var-id varT]]
(case args
(^ (list objectC))
- (do Monad<Lux>
- [objectA (&;with-expected-type (type varT)
+ (do macro;Monad<Lux>
+ [objectA (&;with-expected-type varT
(analyse objectC))
objectT (&;within-type-env
(TC;read-var var-id))
_ (check-object objectT)
- expectedT macro;expected-type
- _ (&;within-type-env
- (TC;check expectedT Bool))]
+ _ (&;infer Bool)]
(wrap (#la;Procedure proc (list objectA))))
_
- (&;fail (@;wrong-amount-error proc +1 (list;size args))))))))
+ (&;fail (@;wrong-arity proc +1 (list;size args))))))))
(def: (object-synchronized proc)
(-> Text @;Proc)
@@ -327,8 +341,8 @@
(function [[var-id varT]]
(case args
(^ (list monitorC exprC))
- (do Monad<Lux>
- [monitorA (&;with-expected-type (type varT)
+ (do macro;Monad<Lux>
+ [monitorA (&;with-expected-type varT
(analyse monitorC))
monitorT (&;within-type-env
(TC;read-var var-id))
@@ -337,19 +351,51 @@
(wrap (#la;Procedure proc (list monitorA exprA))))
_
- (&;fail (@;wrong-amount-error proc +2 (list;size args))))))))
+ (&;fail (@;wrong-arity proc +2 (list;size args))))))))
(host;import java.lang.Object)
(host;import java.lang.ClassLoader)
+(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.ParameterizedType
+ (getRawType [] java.lang.reflect.Type)
+ (getActualTypeArguments [] (Array java.lang.reflect.Type)))
+
+(host;import (java.lang.reflect.TypeVariable d)
+ (getName [] String)
+ (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.Modifier
+ (#static isStatic [int] boolean)
+ (#static isFinal [int] boolean))
+
+(host;import java.lang.reflect.Field
+ (getDeclaringClass [] (java.lang.Class Object))
+ (getModifiers [] int)
+ (getGenericType [] java.lang.reflect.Type))
+
(host;import (java.lang.Class c)
+ (getName [] String)
(#static forName [String boolean ClassLoader] #try (Class Object))
- (isAssignableFrom [(Class Object)] boolean))
+ (isAssignableFrom [(Class Object)] boolean)
+ (getTypeParameters [] (Array (TypeVariable (Class c))))
+ (getGenericInterfaces [] (Array java.lang.reflect.Type))
+ (getGenericSuperclass [] java.lang.reflect.Type)
+ (getDeclaredField [String] #try Field))
(def: (load-class name)
(-> Text (Lux (Class Object)))
- (do Monad<Lux>
+ (do macro;Monad<Lux>
[class-loader &host;class-loader]
(case (Class.forName [name false class-loader])
(#R;Success [class])
@@ -360,11 +406,13 @@
(def: (sub-class? super sub)
(-> Text Text (Lux Bool))
- (do Monad<Lux>
+ (do macro;Monad<Lux>
[super (load-class super)
sub (load-class sub)]
(wrap (Class.isAssignableFrom [sub] super))))
+(exception: #export Not-Throwable)
+
(def: (object-throw proc)
(-> Text @;Proc)
(function [analyse args]
@@ -372,8 +420,8 @@
(function [[var-id varT]]
(case args
(^ (list exceptionC))
- (do Monad<Lux>
- [exceptionA (&;with-expected-type (type varT)
+ (do macro;Monad<Lux>
+ [exceptionA (&;with-expected-type varT
(analyse exceptionC))
exceptionT (&;within-type-env
(TC;read-var var-id))
@@ -382,36 +430,60 @@
_ (: (Lux Unit)
(if ?
(wrap [])
- (&;fail (format "Must throw a sub-class of java.lang.Throwable: " exception-class))))
- expectedT macro;expected-type
- _ (&;within-type-env
- (TC;check expectedT Bottom))]
+ (&;throw Not-Throwable exception-class)))
+ _ (&;infer Bottom)]
(wrap (#la;Procedure proc (list exceptionA))))
_
- (&;fail (@;wrong-amount-error proc +1 (list;size args))))))))
+ (&;fail (@;wrong-arity proc +1 (list;size args))))))))
(def: (object-class proc)
(-> Text @;Proc)
(function [analyse args]
+ (case args
+ (^ (list classC))
+ (case classC
+ [_ (#;Text class)]
+ (do macro;Monad<Lux>
+ [_ (load-class class)
+ _ (&;infer (#;Host "java.lang.Class" (list (#;Host class (list)))))]
+ (wrap (#la;Procedure proc (list (#la;Text class)))))
+
+ _
+ (&;fail (format "Wrong syntax for '" proc "'.")))
+
+ _
+ (&;fail (@;wrong-arity proc +1 (list;size args))))))
+
+(exception: #export Cannot-Be-Instance)
+
+(def: (object-instance? proc)
+ (-> Text @;Proc)
+ (function [analyse args]
(&common;with-var
(function [[var-id varT]]
(case args
- (^ (list classC))
+ (^ (list classC objectC))
(case classC
[_ (#;Text class)]
- (do Monad<Lux>
- [_ (load-class class)
- expectedT macro;expected-type
- _ (&;within-type-env
- (TC;check expectedT (#;Host "java.lang.Class" (list (#;Host class (list))))))]
- (wrap (#la;Procedure proc (list (#la;Text class)))))
+ (do macro;Monad<Lux>
+ [objectA (&;with-expected-type varT
+ (analyse objectC))
+ objectT (&;within-type-env
+ (TC;read-var var-id))
+ object-class (check-object objectT)
+ ? (sub-class? class object-class)]
+ (if ?
+ (do @
+ [_ (&;infer Bool)]
+ (wrap (#la;Procedure proc (list (#la;Text class)))))
+ (&;throw Cannot-Be-Instance (format object-class " !<= " class))))
_
(&;fail (format "Wrong syntax for '" proc "'.")))
_
- (&;fail (@;wrong-amount-error proc +1 (list;size args))))))))
+ (&;fail (@;wrong-arity proc +2 (list;size args))))))))
(def: object-procs
@;Bundle
@@ -422,6 +494,239 @@
(@;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 []))
+
+(exception: #export Cannot-Convert-To-Class)
+
+(def: (type-to-class type)
+ (-> java.lang.reflect.Type (Lux Text))
+ (cond (host;instance? Class type)
+ (lux/wrap (Class.getName [] (:! Class type)))
+
+ (host;instance? ParameterizedType type)
+ (type-to-class (ParameterizedType.getRawType [] (:! ParameterizedType type)))
+
+ ## else
+ (&;throw Cannot-Convert-To-Class (type-descriptor type))))
+
+(def: (adjust parent type)
+ (-> java.lang.reflect.Type Type (Lux Type))
+ (&;fail "UNIMPLEMENTED"))
+
+(exception: #export Cannot-Find-Lineage)
+
+(def: (up-cast super-class sub-class type)
+ (-> Text Text Type (Lux Type))
+ (if (text/= super-class sub-class)
+ (lux/wrap type)
+ (do macro;Monad<Lux>
+ [super (load-class super-class)
+ sub (load-class sub-class)
+ parent (case (|> (list& (Class.getGenericSuperclass [] sub)
+ (array;to-list (Class.getGenericInterfaces [] sub)))
+ (list;filter (function check [class]
+ (cond (host;instance? Class class)
+ (Class.isAssignableFrom [(:! Class class)] super)
+
+ (host;instance? ParameterizedType class)
+ (check (ParameterizedType.getRawType [] (:! ParameterizedType class)))
+
+ ## else
+ false)))
+ list;head)
+ (#;Some parent)
+ (wrap parent)
+
+ #;None
+ (&;throw Cannot-Find-Lineage (format "from: " sub-class "\n"
+ " to: " super-class)))
+ parent-class (type-to-class parent)
+ upped (adjust parent type)]
+ (up-cast super-class parent-class type))))
+
+(def: (with-super-type super-class analysis)
+ (All [a] (-> Text (Lux a) (Lux [Type Type a])))
+ (&common;with-var
+ (function [[var-id varT]]
+ (do macro;Monad<Lux>
+ [output (&;with-expected-type varT
+ analysis)
+ subT (&;within-type-env
+ (TC;read-var var-id))
+ sub-class (check-object subT)
+ ? (sub-class? super-class sub-class)
+ _ (&;assert (format "'" sub-class "' is not a sub-class of '" sub-class "'.")
+ ?)
+ superT (up-cast super-class sub-class subT)]
+ (wrap [superT subT output])))))
+
+(def: (find-field class-name field-name)
+ (-> Text Text (Lux [(Class Object) Field]))
+ (do macro;Monad<Lux>
+ [class (load-class class-name)]
+ (case (Class.getDeclaredField [field-name] class)
+ (#R;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 _)
+ (&;fail (format "Unknown field '" field-name "' for class '" class-name "'.")))))
+
+(def: (translate-type java-type)
+ (-> java.lang.reflect.Type (Lux Type))
+ (cond (host;instance? Class java-type)
+ (lux/wrap (#;Host (Class.getName [] (:! Class java-type)) (list)))
+
+ (host;instance? GenericArrayType java-type)
+ (do macro;Monad<Lux>
+ [#let [innerJT (GenericArrayType.getGenericComponentType [] (:! GenericArrayType java-type))]
+ innerT (translate-type innerJT)]
+ (wrap (#;Host "#Array" (list innerT))))
+
+ (host;instance? ParameterizedType java-type)
+ (do macro;Monad<Lux>
+ [#let [rawJT (ParameterizedType.getRawType [] (:! ParameterizedType java-type))
+ paramsJT+ (array;to-list (ParameterizedType.getActualTypeArguments [] (:! ParameterizedType java-type)))]
+ _ (&;assert (format "Expected class, but got something else: " (type-descriptor java-type))
+ (host;instance? Class rawJT))
+ paramsT+ (monad;map @ translate-type paramsJT+)]
+ (wrap (#;Host (Class.getName [] (:! Class rawJT)) paramsT+)))
+
+ ## else
+ (&;fail (format "Cannot translate type: " (type-descriptor java-type)))))
+
+(def: (static-field class-name field-name)
+ (-> Text Text (Lux [Type Bool]))
+ (do macro;Monad<Lux>
+ [[class field] (find-field class-name field-name)
+ #let [modifiers (Field.getModifiers [] field)]]
+ (if (Modifier.isStatic [modifiers])
+ (let [fieldJT (Field.getGenericType [] field)]
+ (do @
+ [fieldT (translate-type fieldJT)]
+ (wrap [fieldT (Modifier.isFinal [modifiers])])))
+ (&;fail (format "Field '" field-name "' of class '" class-name "' is not static.")))))
+
+(def: (virtual-field class-name field-name objectT)
+ (-> Text Text Type (Lux [Type Bool]))
+ (do macro;Monad<Lux>
+ [[class field] (find-field class-name field-name)
+ #let [modifiers (Field.getModifiers [] field)]]
+ (if (not (Modifier.isStatic [modifiers]))
+ (let [fieldJT (Field.getGenericType [] field)]
+ (do @
+ [fieldT (translate-type fieldJT)]
+ (wrap [fieldT (Modifier.isFinal [modifiers])])))
+ (&;fail (format "Field '" field-name "' of class '" class-name "' is static.")))))
+
+(def: (static-get proc)
+ (-> Text @;Proc)
+ (function [analyse args]
+ (case args
+ (^ (list classC fieldC))
+ (case [classC fieldC]
+ [[_ (#;Text class)] [_ (#;Text field)]]
+ (do macro;Monad<Lux>
+ [[fieldT final?] (static-field class field)
+ _ (&;infer fieldT)]
+ (wrap (#la;Procedure proc (list (#la;Text class) (#la;Text field)))))
+
+ _
+ (&;fail (format "Wrong syntax for '" proc "'.")))
+
+ _
+ (&;fail (@;wrong-arity proc +2 (list;size args))))))
+
+(exception: #export Final-Field)
+
+(def: (static-put proc)
+ (-> Text @;Proc)
+ (function [analyse args]
+ (case args
+ (^ (list classC fieldC valueC))
+ (case [classC fieldC]
+ [[_ (#;Text class)] [_ (#;Text field)]]
+ (do macro;Monad<Lux>
+ [[fieldT final?] (static-field class field)
+ _ (&;assert (Final-Field (format class "#" field))
+ (not final?))
+ valueA (&;with-expected-type fieldT
+ (analyse valueC))
+ _ (&;infer Unit)]
+ (wrap (#la;Procedure proc (list (#la;Text class) (#la;Text field) valueA))))
+
+ _
+ (&;fail (format "Wrong syntax for '" proc "'.")))
+
+ _
+ (&;fail (@;wrong-arity proc +3 (list;size args))))))
+
+(def: (virtual-get proc)
+ (-> Text @;Proc)
+ (function [analyse args]
+ (case args
+ (^ (list classC fieldC objectC))
+ (case [classC fieldC]
+ [[_ (#;Text class)] [_ (#;Text field)]]
+ (do macro;Monad<Lux>
+ [[superT objectT objectA] (with-super-type class
+ (analyse objectC))
+ [fieldT final?] (virtual-field class field objectT)
+ _ (&;infer fieldT)]
+ (wrap (#la;Procedure proc (list (#la;Text class) (#la;Text field) objectA))))
+
+ _
+ (&;fail (format "Wrong syntax for '" proc "'.")))
+
+ _
+ (&;fail (@;wrong-arity proc +3 (list;size args))))))
+
+(def: (virtual-put proc)
+ (-> Text @;Proc)
+ (function [analyse args]
+ (case args
+ (^ (list classC fieldC valueC objectC))
+ (case [classC fieldC]
+ [[_ (#;Text class)] [_ (#;Text field)]]
+ (do macro;Monad<Lux>
+ [[superT objectT objectA] (with-super-type class
+ (analyse objectC))
+ [fieldT final?] (virtual-field class field objectT)
+ _ (&;assert (Final-Field (format class "#" field))
+ (not final?))
+ valueA (&;with-expected-type fieldT
+ (analyse valueC))
+ _ (&;infer Unit)]
+ (wrap (#la;Procedure proc (list (#la;Text class) (#la;Text field) valueA objectA))))
+
+ _
+ (&;fail (format "Wrong syntax for '" proc "'.")))
+
+ _
+ (&;fail (@;wrong-arity proc +4 (list;size args))))))
+
+(def: member-procs
+ @;Bundle
+ (<| (@;prefix "member")
+ (|> (d;new text;Hash<Text>)
+ (d;merge (<| (@;prefix "static")
+ (|> (d;new text;Hash<Text>)
+ (@;install "get" static-get)
+ (@;install "put" static-put)
+ )))
+ (d;merge (<| (@;prefix "virtual")
+ (|> (d;new text;Hash<Text>)
+ (@;install "get" virtual-get)
+ (@;install "put" virtual-put)
+ )))
)))
(def: #export procedures
@@ -436,4 +741,5 @@
(d;merge char-procs)
(d;merge array-procs)
(d;merge object-procs)
+ (d;merge member-procs)
)))