- WIP: Added support for inheritance.

1 files changed, 127 insertions, 104 deletions

diff --git a/new-luxc/source/luxc/analyser/procedure/host.jvm.lux b/new-luxc/source/luxc/analyser/procedure/host.jvm.lux
index 2a02ed6b2..8cb21e80c 100644
--- a/new-luxc/source/luxc/analyser/procedure/host.jvm.lux
+++ b/new-luxc/source/luxc/analyser/procedure/host.jvm.lux
@@ -5,6 +5,7 @@
                 ["ex" exception #+ exception:])
        (concurrency ["A" atom])
        (data ["R" result]
+             [product]
              [text "text/" Eq<Text>]
              (text format
                    ["l" lexer])
@@ -13,7 +14,7 @@
                    ["d" dict]))
        [macro "lux/" Monad<Lux>]
        [type]
-       (type ["TC" check])
+       (type ["tc" check])
        [host])
   (luxc ["&" base]
         ["&;" host]
@@ -22,6 +23,8 @@
   ["@" ../common]
   )
 
+(def: null-class Text "#Null")
+
 (do-template [<name> <class>]
   [(def: #export <name> Type (#;Host <class> (list)))]
 
@@ -259,7 +262,7 @@
             [arrayA (&;with-expected-type (type (Array varT))
                       (analyse arrayC))
              elemT (&;within-type-env
-                    (TC;read-var var-id))
+                    (tc;read-var var-id))
              [elemT elem-class] (box-array-element-type elemT)
              idxA (&;with-expected-type Nat
                     (analyse idxC))
@@ -280,7 +283,7 @@
             [arrayA (&;with-expected-type (type (Array varT))
                       (analyse arrayC))
              elemT (&;within-type-env
-                    (TC;read-var var-id))
+                    (tc;read-var var-id))
              [valueT elem-class] (box-array-element-type elemT)
              idxA (&;with-expected-type Nat
                     (analyse idxC))
@@ -326,7 +329,7 @@
             [objectA (&;with-expected-type varT
                        (analyse objectC))
              objectT (&;within-type-env
-                      (TC;read-var var-id))
+                      (tc;read-var var-id))
              _ (check-object objectT)
              _ (&;infer Bool)]
             (wrap (#la;Procedure proc (list objectA))))
@@ -345,7 +348,7 @@
             [monitorA (&;with-expected-type varT
                         (analyse monitorC))
              monitorT (&;within-type-env
-                       (TC;read-var var-id))
+                       (tc;read-var var-id))
              _ (check-object monitorT)
              exprA (analyse exprC)]
             (wrap (#la;Procedure proc (list monitorA exprA))))
@@ -424,7 +427,7 @@
             [exceptionA (&;with-expected-type varT
                           (analyse exceptionC))
              exceptionT (&;within-type-env
-                         (TC;read-var var-id))
+                         (tc;read-var var-id))
              exception-class (check-object exceptionT)
              ? (sub-class? "java.lang.Throwable" exception-class)
              _ (: (Lux Unit)
@@ -470,7 +473,7 @@
               [objectA (&;with-expected-type varT
                          (analyse objectC))
                objectT (&;within-type-env
-                        (TC;read-var var-id))
+                        (tc;read-var var-id))
                object-class (check-object objectT)
                ? (sub-class? class object-class)]
               (if ?
@@ -497,73 +500,87 @@
           (@;install "instance?" object-instance?)
           )))
 
+(exception: #export Final-Field)
+
+(exception: #export Cannot-Convert-To-Class)
+(exception: #export Cannot-Convert-To-Lux-Type)
+(exception: #export Cannot-Cast-To-Primitive)
+(exception: #export Cannot-Cast-From-Primitive)
+
 (def: type-descriptor
   (-> java.lang.reflect.Type Text)
   (java.lang.reflect.Type.getTypeName []))
 
-(exception: #export Cannot-Convert-To-Class)
-
-(def: (type-to-class type)
+(def: (java-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)))
+        (java-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: (java-type-to-lux-type java-type)
+  (-> java.lang.reflect.Type (Lux Type))
+  (cond (host;instance? Class java-type)
+        (let [class-name (Class.getName [] (:! (Class Object) java-type))]
+          (lux/wrap (#;Host class-name (list))))
+
+        (host;instance? ParameterizedType java-type)
+        (java-type-to-lux-type (ParameterizedType.getRawType [] (:! ParameterizedType java-type)))
+
+        (host;instance? GenericArrayType java-type)
+        (do macro;Monad<Lux>
+          [#let [innerJT (GenericArrayType.getGenericComponentType [] (:! GenericArrayType java-type))]
+           innerT (java-type-to-lux-type innerJT)]
+          (wrap (#;Host "#Array" (list innerT))))
+
+        ## else
+        (&;throw Cannot-Convert-To-Lux-Type (type-descriptor java-type))))
+
+(def: (up-cast super sub)
+  (-> Type Type (Lux Type))
+  (do macro;Monad<Lux>
+    [super-name (check-object super)
+     sub-name (check-object sub)]
+    (cond (d;contains? super-name boxes)
+          (&;throw Cannot-Cast-To-Primitive super-name)
+
+          (d;contains? sub-name boxes)
+          (&;throw Cannot-Cast-From-Primitive sub-name)
+
+          (text/= super-name sub-name)
+          (wrap sub)
+
+          (text/= null-class sub-name)
+          (wrap super)
+
+          ## else
+          (do @
+            [super-class (load-class super-name)
+             sub-class (load-class sub-name)
+             _ (&;assert (format "Class '" sub-name "' is not a sub-class of class '" super-name "'.")
+                         (Class.isAssignableFrom [sub-class] super-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 [sub-class] super-class)])))
+                                         (list& (Class.getGenericSuperclass [] sub-class)
+                                                (array;to-list (Class.getGenericInterfaces [] sub-class))))]
+            (case (|> candiate-parents
+                      (list;filter product;right)
+                      (list/map product;left))
+              (#;Cons parent _)
+              (do @
+                [parentT (java-type-to-lux-type parent)]
+                (up-cast super parentT))
+              
+              #;Nil
+              (&;fail (format "No valid path between " (%type sub) "and " (%type super) ".")))))))
 
 (def: (find-field class-name field-name)
   (-> Text Text (Lux [(Class Object) Field]))
@@ -580,53 +597,55 @@
       (#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)]]
+    [[class fieldJ] (find-field class-name field-name)
+     #let [modifiers (Field.getModifiers [] fieldJ)]]
     (if (Modifier.isStatic [modifiers])
-      (let [fieldJT (Field.getGenericType [] field)]
+      (let [fieldJT (Field.getGenericType [] fieldJ)]
         (do @
-          [fieldT (translate-type fieldJT)]
+          [fieldT (java-type-to-lux-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)]]
+    [[class fieldJ] (find-field class-name field-name)
+     #let [modifiers (Field.getModifiers [] fieldJ)]]
     (if (not (Modifier.isStatic [modifiers]))
-      (let [fieldJT (Field.getGenericType [] field)]
+      (let [fieldJT (Field.getGenericType [] fieldJ)]
         (do @
-          [fieldT (translate-type fieldJT)]
+          [fieldT (java-type-to-lux-type fieldJT)]
           (wrap [fieldT (Modifier.isFinal [modifiers])])))
       (&;fail (format "Field '" field-name "' of class '" class-name "' is static.")))))
 
+(def: (analyse-object class analyse sourceC)
+  (-> Text &;Analyser Code (Lux [Type la;Analysis]))
+  (<| &common;with-var (function [[var-id varT]])
+      (do macro;Monad<Lux>
+        [target-class (load-class class)
+         targetT (java-type-to-lux-type (:! java.lang.reflect.Type
+                                            target-class))
+         sourceA (&;with-expected-type varT
+                   (analyse sourceC))
+         sourceT (&;within-type-env
+                  (tc;read-var var-id))
+         castT (up-cast targetT sourceT)]
+        (wrap [castT sourceA]))))
+
+(def: (analyse-input analyse targetT sourceC)
+  (-> &;Analyser Type Code (Lux [Type la;Analysis]))
+  (<| &common;with-var (function [[var-id varT]])
+      (do macro;Monad<Lux>
+        [sourceA (&;with-expected-type varT
+                   (analyse sourceC))
+         sourceT (&;within-type-env
+                  (tc;read-var var-id))
+         castT (up-cast targetT sourceT)]
+        (wrap [castT sourceA]))))
+
 (def: (static-get proc)
   (-> Text @;Proc)
   (function [analyse args]
@@ -636,7 +655,10 @@
         [[_ (#;Text class)] [_ (#;Text field)]]
         (do macro;Monad<Lux>
           [[fieldT final?] (static-field class field)
-           _ (&;infer fieldT)]
+           expectedT macro;expected-type
+           castT (up-cast expectedT fieldT)
+           _ (&;within-type-env
+              (tc;check expectedT castT))]
           (wrap (#la;Procedure proc (list (#la;Text class) (#la;Text field)))))
 
         _
@@ -645,8 +667,6 @@
       _
       (&;fail (@;wrong-arity proc +2 (list;size args))))))
 
-(exception: #export Final-Field)
-
 (def: (static-put proc)
   (-> Text @;Proc)
   (function [analyse args]
@@ -658,8 +678,9 @@
           [[fieldT final?] (static-field class field)
            _ (&;assert (Final-Field (format class "#" field))
                        (not final?))
-           valueA (&;with-expected-type fieldT
-                    (analyse valueC))
+           [valueT valueA] (analyse-input analyse fieldT valueC)
+           _ (&;within-type-env
+              (tc;check fieldT valueT))
            _ (&;infer Unit)]
           (wrap (#la;Procedure proc (list (#la;Text class) (#la;Text field) valueA))))
 
@@ -677,10 +698,12 @@
       (case [classC fieldC]
         [[_ (#;Text class)] [_ (#;Text field)]]
         (do macro;Monad<Lux>
-          [[superT objectT objectA] (with-super-type class
-                                      (analyse objectC))
+          [[objectT objectA] (analyse-object class analyse objectC)
            [fieldT final?] (virtual-field class field objectT)
-           _ (&;infer fieldT)]
+           expectedT macro;expected-type
+           castT (up-cast expectedT fieldT)
+           _ (&;within-type-env
+              (tc;check expectedT castT))]
           (wrap (#la;Procedure proc (list (#la;Text class) (#la;Text field) objectA))))
 
         _
@@ -697,13 +720,13 @@
       (case [classC fieldC]
         [[_ (#;Text class)] [_ (#;Text field)]]
         (do macro;Monad<Lux>
-          [[superT objectT objectA] (with-super-type class
-                                      (analyse objectC))
+          [[objectT objectA] (analyse-object 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))
+           [valueT valueA] (analyse-input analyse fieldT valueC)
+           _ (&;within-type-env
+              (tc;check fieldT valueT))
            _ (&;infer Unit)]
           (wrap (#la;Procedure proc (list (#la;Text class) (#la;Text field) valueA objectA))))