- Added tests for host procedures.

1 files changed, 118 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 c8dc5a38a..c75d6efd4 100644
--- a/new-luxc/source/luxc/analyser/procedure/host.jvm.lux
+++ b/new-luxc/source/luxc/analyser/procedure/host.jvm.lux
@@ -11,6 +11,7 @@
                    [array #+ Array]
                    ["d" dict]))
        [macro #+ Monad<Lux>]
+       [type]
        (type ["TC" check])
        [host])
   (luxc ["&" base]
@@ -20,26 +21,32 @@
   ["@" ../common]
   )
 
-(def: Boolean Type (host java.lang.Boolean))
-(def: Byte Type (host java.lang.Byte))
-(def: Short Type (host java.lang.Short))
-(def: Integer Type (host java.lang.Integer))
-(def: Long Type (host java.lang.Long))
-(def: Float Type (host java.lang.Float))
-(def: Double Type (host java.lang.Double))
-(def: Character Type (host java.lang.Character))
-(def: String Type (host java.lang.String))
-
-(def: boolean Type (host boolean))
-(def: byte Type (host byte))
-(def: short Type (host short))
-(def: int Type (host int))
-(def: long Type (host long))
-(def: float Type (host float))
-(def: double Type (host double))
-(def: char Type (host char))
-
-(def: converter-procs
+(do-template [<name> <class>]
+  [(def: #export <name> Type (#;Host <class> (list)))]
+
+  ## Boxes
+  [Boolean   "java.lang.Boolean"]
+  [Byte      "java.lang.Byte"]
+  [Short     "java.lang.Short"]
+  [Integer   "java.lang.Integer"]
+  [Long      "java.lang.Long"]
+  [Float     "java.lang.Float"]
+  [Double    "java.lang.Double"]
+  [Character "java.lang.Character"]
+  [String    "java.lang.String"]
+
+  ## Primitives
+  [boolean   "boolean"]
+  [byte      "byte"]
+  [short     "short"]
+  [int       "int"]
+  [long      "long"]
+  [float     "float"]
+  [double    "double"]
+  [char      "char"]
+  )
+
+(def: conversion-procs
   @;Bundle
   (<| (@;prefix "convert")
       (|> (d;new text;Hash<Text>)
@@ -73,14 +80,14 @@
      @;Bundle
      (<| (@;prefix <prefix>)
          (|> (d;new text;Hash<Text>)
-             (@;install "add" (@;binary <type> <type> <type>))
-             (@;install "sub" (@;binary <type> <type> <type>))
-             (@;install "mul" (@;binary <type> <type> <type>))
-             (@;install "div" (@;binary <type> <type> <type>))
-             (@;install "rem" (@;binary <type> <type> <type>))
-             (@;install "eq" (@;binary <type> <type> Boolean))
-             (@;install "lt" (@;binary <type> <type> Boolean))
-             (@;install "gt" (@;binary <type> <type> Boolean))
+             (@;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 ">" (@;binary <type> <type> Boolean))
              (@;install "and" (@;binary <type> <type> <type>))
              (@;install "or" (@;binary <type> <type> <type>))
              (@;install "xor" (@;binary <type> <type> <type>))
@@ -98,14 +105,14 @@
      @;Bundle
      (<| (@;prefix <prefix>)
          (|> (d;new text;Hash<Text>)
-             (@;install "add" (@;binary <type> <type> <type>))
-             (@;install "sub" (@;binary <type> <type> <type>))
-             (@;install "mul" (@;binary <type> <type> <type>))
-             (@;install "div" (@;binary <type> <type> <type>))
-             (@;install "rem" (@;binary <type> <type> <type>))
-             (@;install "eq" (@;binary <type> <type> Boolean))
-             (@;install "lt" (@;binary <type> <type> Boolean))
-             (@;install "gt" (@;binary <type> <type> Boolean))
+             (@;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 ">" (@;binary <type> <type> Boolean))
              )))]
 
   [float-procs  "float"  Float]
@@ -116,12 +123,12 @@
   @;Bundle
   (<| (@;prefix "char")
       (|> (d;new text;Hash<Text>)
-          (@;install "ceq" (@;binary Character Character Boolean))
-          (@;install "clt" (@;binary Character Character Boolean))
-          (@;install "cgt" (@;binary Character Character Boolean))
+          (@;install "=" (@;binary Character Character Boolean))
+          (@;install "<" (@;binary Character Character Boolean))
+          (@;install ">" (@;binary Character Character Boolean))
           )))
 
-(def: primitive-boxes
+(def: #export boxes
   (d;Dict Text Text)
   (|> (list ["boolean" "java.lang.Boolean"]
             ["byte" "java.lang.Byte"]
@@ -133,21 +140,6 @@
             ["char" "java.lang.Character"])
       (d;from-list text;Hash<Text>)))
 
-(def: array-type
-  (l;Lexer [Type Nat Text])
-  (do p;Monad<Parser>
-    [subs (p;some (l;this "["))
-     #let [level (list;size subs)]
-     class (l;many l;any)]
-    (wrap [(list/fold (function [_ inner]
-                        (type (Array inner)))
-                      (#;Host (|> (d;get class primitive-boxes)
-                                  (default class))
-                              (list))
-                      (list;n.range +1 level))
-           level
-           class])))
-
 (def: (array-length proc)
   (-> Text @;Proc)
   (function [analyse args]
@@ -166,34 +158,77 @@
           _
           (&;fail (@;wrong-amount-error proc +1 (list;size args))))))))
 
+(def: (invalid-array-type arrayT)
+  (-> Type Text)
+  (format "Invalid type for array: " (%type arrayT)))
+
 (def: (array-new proc)
   (-> Text @;Proc)
   (function [analyse args]
     (case args
-      (^ (list classC lengthC))
-      (case classC
-        [_ (#;Text classC)]
-        (do Monad<Lux>
-          [lengthA (&;with-expected-type Nat
-                     (analyse lengthC))
-           arrayT (case (l;run classC array-type)
-                    (#R;Success [innerT level elem-class])
-                    (wrap (type (Array innerT)))
-
-                    (#R;Error error)
-                    (&;fail error))
-           expectedT macro;expected-type
-           _ (&;within-type-env
-              (TC;check expectedT arrayT))]
-          (wrap (#la;Procedure proc (list (#la;Text classC) lengthA))))
-
-        _
-        (&;fail (format "Wrong syntax for '" proc "'.")))
+      (^ (list lengthC))
+      (do Monad<Lux>
+        [lengthA (&;with-expected-type Nat
+                   (analyse lengthC))
+         expectedT macro;expected-type
+         [level elem-class] (: (Lux [Nat Text])
+                               (loop [analysisT expectedT
+                                      level +0]
+                                 (case analysisT
+                                   (#;Apply inputT funcT)
+                                   (case (type;apply (list inputT) funcT)
+                                     (#;Some outputT)
+                                     (recur outputT level)
+
+                                     #;None
+                                     (&;fail (invalid-array-type expectedT)))
+
+                                   (^ (#;Host "#Array" (list elemT)))
+                                   (recur elemT (n.inc level))
+
+                                   (#;Host class _)
+                                   (wrap [level class])
+                                   
+                                   _
+                                   (&;fail (invalid-array-type expectedT)))))
+         _ (&;assert "Must have at least 1 level of nesting in array type."
+                     (n.> +0 level))]
+        (wrap (#la;Procedure proc (list (#la;Nat level) (#la;Text elem-class) lengthA))))
 
       _
-      (&;fail (@;wrong-amount-error proc +2 (list;size args))))))
+      (&;fail (@;wrong-amount-error proc +1 (list;size args))))))
+
+(def: (check-object objectT)
+  (-> Type (Lux Text))
+  (case objectT
+    (#;Host name _)
+    (if (d;contains? name boxes)
+      (&;fail (format "Primitives are not objects: " name))
+      (:: Monad<Lux> wrap name))
 
-(def: (array-load proc)
+    _
+    (&;fail (format "Non-object type: " (%type objectT)))))
+
+(def: (box-array-element-type elemT)
+  (-> Type (Lux [Type Text]))
+  (do Monad<Lux>
+    []
+    (case elemT
+      (#;Host name #;Nil)
+      (let [boxed-name (|> (d;get name boxes)
+                           (default name))]
+        (wrap [(#;Host boxed-name #;Nil)
+               boxed-name]))
+
+      (#;Host name _)
+      (if (d;contains? name boxes)
+        (&;fail (format "Primitives cannot be parameterized: " name))
+        (:: Monad<Lux> wrap [elemT name]))
+
+      _
+      (&;fail (format "Invalid type for array element: " (%type elemT))))))
+
+(def: (array-read proc)
   (-> Text @;Proc)
   (function [analyse args]
     (&common;with-var
@@ -205,12 +240,7 @@
                       (analyse arrayC))
              elemT (&;within-type-env
                     (TC;read-var var-id))
-             elem-class (case elemT
-                          (#;Host name _)
-                          (wrap name)
-
-                          _
-                          (&;fail (format "Invalid type for array element: " (%type elemT))))
+             [elemT elem-class] (box-array-element-type elemT)
              idxA (&;with-expected-type Nat
                     (analyse idxC))
              expectedT macro;expected-type
@@ -221,7 +251,7 @@
           _
           (&;fail (@;wrong-amount-error proc +2 (list;size args))))))))
 
-(def: (array-store proc)
+(def: (array-write proc)
   (-> Text @;Proc)
   (function [analyse args]
     (&common;with-var
@@ -233,15 +263,10 @@
                       (analyse arrayC))
              elemT (&;within-type-env
                     (TC;read-var var-id))
-             elem-class (case elemT
-                          (#;Host name _)
-                          (wrap name)
-
-                          _
-                          (&;fail (format "Invalid type for array element: " (%type elemT))))
+             [valueT elem-class] (box-array-element-type elemT)
              idxA (&;with-expected-type Nat
                     (analyse idxC))
-             valueA (&;with-expected-type elemT
+             valueA (&;with-expected-type valueT
                       (analyse valueC))
              expectedT macro;expected-type
              _ (&;within-type-env
@@ -257,21 +282,10 @@
       (|> (d;new text;Hash<Text>)
           (@;install "length" array-length)
           (@;install "new" array-new)
-          (@;install "load" array-load)
-          (@;install "store" array-store)
+          (@;install "read" array-read)
+          (@;install "write" array-write)
           )))
 
-(def: (check-object objectT)
-  (-> Type (Lux Text))
-  (case objectT
-    (#;Host name _)
-    (if (d;contains? name primitive-boxes)
-      (&;fail (format "Primitives are not objects: " name))
-      (:: Monad<Lux> wrap name))
-
-    _
-    (&;fail (format "Non-object type: " (%type objectT)))))
-
 (def: (object-null proc)
   (-> Text @;Proc)
   (function [analyse args]
@@ -414,7 +428,7 @@
   @;Bundle
   (<| (@;prefix "jvm")
       (|> (d;new text;Hash<Text>)
-          (d;merge converter-procs)
+          (d;merge conversion-procs)
           (d;merge int-procs)
           (d;merge long-procs)
           (d;merge float-procs)