Implemented machinery for "lux syntax char case!".

3 files changed, 172 insertions, 102 deletions

diff --git a/new-luxc/source/luxc/lang/host/jvm/inst.lux b/new-luxc/source/luxc/lang/host/jvm/inst.lux
index 33aa290df..040f6f04a 100644
--- a/new-luxc/source/luxc/lang/host/jvm/inst.lux
+++ b/new-luxc/source/luxc/lang/host/jvm/inst.lux
@@ -8,6 +8,7 @@
     ["p" parser
      ["s" code]]]
    [data
+    ["." product]
     ["." maybe]
     ["." error]
     [text
@@ -16,6 +17,7 @@
      ["." list ("#@." functor)]]]
    [macro
     ["." code]
+    ["." template]
     [syntax (#+ syntax:)]]
    [target
     [jvm
@@ -34,7 +36,7 @@
       (list@map (function (_ code) (` ((~' #static) (~ (code.local-identifier code)) (~' int)))))
       wrap))
 
-(`` (import: org/objectweb/asm/Opcodes
+(`` (import: #long org/objectweb/asm/Opcodes
       (#static NOP int)
 
       ## Conversion
@@ -103,42 +105,43 @@
       (~~ (declare RETURN IRETURN LRETURN DRETURN ARETURN))
       ))
 
-(import: org/objectweb/asm/Label
+(import: #long org/objectweb/asm/Label
   (new []))
 
-(import: org/objectweb/asm/MethodVisitor
+(import: #long org/objectweb/asm/MethodVisitor
   (visitCode [] void)
   (visitMaxs [int int] void)
   (visitEnd [] void)
   (visitInsn [int] void)
-  (visitLdcInsn [Object] void)
-  (visitFieldInsn [int String String String] void)
-  (visitTypeInsn [int String] void)
+  (visitLdcInsn [java/lang/Object] void)
+  (visitFieldInsn [int java/lang/String java/lang/String java/lang/String] void)
+  (visitTypeInsn [int java/lang/String] void)
   (visitVarInsn [int int] void)
   (visitIntInsn [int int] void)
-  (visitMethodInsn [int String String String boolean] void)
-  (visitLabel [Label] void)
-  (visitJumpInsn [int Label] void)
-  (visitTryCatchBlock [Label Label Label String] void)
-  (visitTableSwitchInsn [int int Label (Array  Label)] void)
+  (visitMethodInsn [int java/lang/String java/lang/String java/lang/String boolean] void)
+  (visitLabel [org/objectweb/asm/Label] void)
+  (visitJumpInsn [int org/objectweb/asm/Label] void)
+  (visitTryCatchBlock [org/objectweb/asm/Label org/objectweb/asm/Label org/objectweb/asm/Label java/lang/String] void)
+  (visitLookupSwitchInsn [org/objectweb/asm/Label (Array int) (Array org/objectweb/asm/Label)] void)
+  (visitTableSwitchInsn [int int org/objectweb/asm/Label (Array org/objectweb/asm/Label)] void)
   )
 
 ## [Insts]
 (def: #export make-label
-  (All [s] (Operation s Label))
+  (All [s] (Operation s org/objectweb/asm/Label))
   (function (_ state)
-    (#error.Success [state (Label::new)])))
+    (#error.Success [state (org/objectweb/asm/Label::new)])))
 
 (def: #export (with-label action)
-  (-> (-> Label Inst) Inst)
-  (action (Label::new)))
+  (All [a] (-> (-> org/objectweb/asm/Label a) a))
+  (action (org/objectweb/asm/Label::new)))
 
 (template [<name> <type> <prepare>]
   [(def: #export (<name> value)
      (-> <type> Inst)
      (function (_ visitor)
        (do-to visitor
-         (MethodVisitor::visitLdcInsn (<prepare> value)))))]
+         (org/objectweb/asm/MethodVisitor::visitLdcInsn (<prepare> value)))))]
 
   [boolean Bit  function.identity]
   [int     Int  host.long-to-int]
@@ -148,21 +151,21 @@
   [string  Text function.identity]
   )
 
-(syntax: (prefix {base s.local-identifier})
-  (wrap (list (` ((~ (code.local-identifier (format "Opcodes::" base))))))))
+(template: (prefix short)
+  (`` ((~~ (template.identifier ["org/objectweb/asm/Opcodes::" short])))))
 
 (def: #export NULL
   Inst
   (function (_ visitor)
     (do-to visitor
-      (MethodVisitor::visitInsn (prefix ACONST_NULL)))))
+      (org/objectweb/asm/MethodVisitor::visitInsn (prefix ACONST_NULL)))))
 
 (template [<name>]
   [(def: #export <name>
      Inst
      (function (_ visitor)
        (do-to visitor
-         (MethodVisitor::visitInsn (prefix <name>)))))]
+         (org/objectweb/asm/MethodVisitor::visitInsn (prefix <name>)))))]
 
   [NOP]
   
@@ -223,7 +226,7 @@
      (-> Nat Inst)
      (function (_ visitor)
        (do-to visitor
-         (MethodVisitor::visitVarInsn (prefix <name>) (.int register)))))]
+         (org/objectweb/asm/MethodVisitor::visitVarInsn (prefix <name>) (.int register)))))]
 
   [ILOAD] [LLOAD] [DLOAD] [ALOAD]
   [ISTORE] [LSTORE] [ASTORE]
@@ -234,13 +237,13 @@
      (-> Text Text Type Inst)
      (function (_ visitor)
        (do-to visitor
-         (MethodVisitor::visitFieldInsn (<inst>) (type.binary-name class) field (type.descriptor type)))))]
+         (org/objectweb/asm/MethodVisitor::visitFieldInsn (<inst>) (type.binary-name class) field (type.descriptor type)))))]
 
-  [GETSTATIC Opcodes::GETSTATIC]
-  [PUTSTATIC Opcodes::PUTSTATIC]
+  [GETSTATIC org/objectweb/asm/Opcodes::GETSTATIC]
+  [PUTSTATIC org/objectweb/asm/Opcodes::PUTSTATIC]
   
-  [PUTFIELD  Opcodes::PUTFIELD]
-  [GETFIELD  Opcodes::GETFIELD]
+  [PUTFIELD  org/objectweb/asm/Opcodes::PUTFIELD]
+  [GETFIELD  org/objectweb/asm/Opcodes::GETFIELD]
   )
 
 (template [<name> <inst>]
@@ -248,40 +251,40 @@
      (-> Text Inst)
      (function (_ visitor)
        (do-to visitor
-         (MethodVisitor::visitTypeInsn (<inst>) (type.binary-name class)))))]
+         (org/objectweb/asm/MethodVisitor::visitTypeInsn (<inst>) (type.binary-name class)))))]
 
-  [CHECKCAST  Opcodes::CHECKCAST]
-  [NEW        Opcodes::NEW]
-  [INSTANCEOF Opcodes::INSTANCEOF]
-  [ANEWARRAY  Opcodes::ANEWARRAY]
+  [CHECKCAST  org/objectweb/asm/Opcodes::CHECKCAST]
+  [NEW        org/objectweb/asm/Opcodes::NEW]
+  [INSTANCEOF org/objectweb/asm/Opcodes::INSTANCEOF]
+  [ANEWARRAY  org/objectweb/asm/Opcodes::ANEWARRAY]
   )
 
 (def: #export (NEWARRAY type)
   (-> Primitive Inst)
   (function (_ visitor)
     (do-to visitor
-      (MethodVisitor::visitIntInsn (Opcodes::NEWARRAY)
-                                   (case type
-                                     #type.Boolean (Opcodes::T_BOOLEAN)
-                                     #type.Byte    (Opcodes::T_BYTE)
-                                     #type.Short   (Opcodes::T_SHORT)
-                                     #type.Int     (Opcodes::T_INT)
-                                     #type.Long    (Opcodes::T_LONG)
-                                     #type.Float   (Opcodes::T_FLOAT)
-                                     #type.Double  (Opcodes::T_DOUBLE)
-                                     #type.Char    (Opcodes::T_CHAR))))))
+      (org/objectweb/asm/MethodVisitor::visitIntInsn (org/objectweb/asm/Opcodes::NEWARRAY)
+                                                     (case type
+                                                       #type.Boolean (org/objectweb/asm/Opcodes::T_BOOLEAN)
+                                                       #type.Byte    (org/objectweb/asm/Opcodes::T_BYTE)
+                                                       #type.Short   (org/objectweb/asm/Opcodes::T_SHORT)
+                                                       #type.Int     (org/objectweb/asm/Opcodes::T_INT)
+                                                       #type.Long    (org/objectweb/asm/Opcodes::T_LONG)
+                                                       #type.Float   (org/objectweb/asm/Opcodes::T_FLOAT)
+                                                       #type.Double  (org/objectweb/asm/Opcodes::T_DOUBLE)
+                                                       #type.Char    (org/objectweb/asm/Opcodes::T_CHAR))))))
 
 (template [<name> <inst>]
   [(def: #export (<name> class method-name method-signature interface?)
      (-> Text Text Method Bit Inst)
      (function (_ visitor)
        (do-to visitor
-         (MethodVisitor::visitMethodInsn (<inst>) (type.binary-name class) method-name (type.method-descriptor method-signature) interface?))))]
+         (org/objectweb/asm/MethodVisitor::visitMethodInsn (<inst>) (type.binary-name class) method-name (type.method-descriptor method-signature) interface?))))]
 
-  [INVOKESTATIC    Opcodes::INVOKESTATIC]
-  [INVOKEVIRTUAL   Opcodes::INVOKEVIRTUAL]
-  [INVOKESPECIAL   Opcodes::INVOKESPECIAL]
-  [INVOKEINTERFACE Opcodes::INVOKEINTERFACE]
+  [INVOKESTATIC    org/objectweb/asm/Opcodes::INVOKESTATIC]
+  [INVOKEVIRTUAL   org/objectweb/asm/Opcodes::INVOKEVIRTUAL]
+  [INVOKESPECIAL   org/objectweb/asm/Opcodes::INVOKESPECIAL]
+  [INVOKEINTERFACE org/objectweb/asm/Opcodes::INVOKEINTERFACE]
   )
 
 (template [<name>]
@@ -289,7 +292,7 @@
      (-> //.Label Inst)
      (function (_ visitor)
        (do-to visitor
-         (MethodVisitor::visitJumpInsn (prefix <name>) @where))))]
+         (org/objectweb/asm/MethodVisitor::visitJumpInsn (prefix <name>) @where))))]
 
   [IF_ICMPEQ] [IF_ICMPGT] [IF_ICMPLT]
   [IF_ICMPNE] [IF_ICMPGE] [IF_ICMPLE]
@@ -298,11 +301,31 @@
   [GOTO]
   )
 
+(def: #export (LOOKUPSWITCH default keys+labels)
+  (-> //.Label (List [Int //.Label]) Inst)
+  (function (_ visitor)
+    (let [keys+labels (list.sort (function (_ left right)
+                                   (i/< (product.left left) (product.left right)))
+                                 keys+labels)
+          array-size (list.size keys+labels)
+          keys-array (host.array int array-size)
+          labels-array (host.array org/objectweb/asm/Label array-size)
+          _ (loop [idx 0]
+              (if (n/< array-size idx)
+                (let [[key label] (maybe.assume (list.nth idx keys+labels))]
+                  (exec
+                    (host.array-write idx (host.long-to-int key) keys-array)
+                    (host.array-write idx label labels-array)
+                    (recur (inc idx))))
+                []))]
+      (do-to visitor
+        (org/objectweb/asm/MethodVisitor::visitLookupSwitchInsn default keys-array labels-array)))))
+
 (def: #export (TABLESWITCH min max default labels)
   (-> Int Int //.Label (List //.Label) Inst)
   (function (_ visitor)
     (let [num-labels (list.size labels)
-          labels-array (host.array Label num-labels)
+          labels-array (host.array org/objectweb/asm/Label num-labels)
           _ (loop [idx 0]
               (if (n/< num-labels idx)
                 (exec (host.array-write idx
@@ -311,19 +334,19 @@
                   (recur (inc idx)))
                 []))]
       (do-to visitor
-        (MethodVisitor::visitTableSwitchInsn min max default labels-array)))))
+        (org/objectweb/asm/MethodVisitor::visitTableSwitchInsn min max default labels-array)))))
 
 (def: #export (try @from @to @handler exception)
   (-> //.Label //.Label //.Label Text Inst)
   (function (_ visitor)
     (do-to visitor
-      (MethodVisitor::visitTryCatchBlock @from @to @handler (type.binary-name exception)))))
+      (org/objectweb/asm/MethodVisitor::visitTryCatchBlock @from @to @handler (type.binary-name exception)))))
 
 (def: #export (label @label)
   (-> //.Label Inst)
   (function (_ visitor)
     (do-to visitor
-      (MethodVisitor::visitLabel @label))))
+      (org/objectweb/asm/MethodVisitor::visitLabel @label))))
 
 (def: #export (array type)
   (-> Type Inst)
diff --git a/new-luxc/source/luxc/lang/translation/jvm/procedure/common.lux b/new-luxc/source/luxc/lang/translation/jvm/procedure/common.lux
index ea67a0d4a..34462d9ba 100644
--- a/new-luxc/source/luxc/lang/translation/jvm/procedure/common.lux
+++ b/new-luxc/source/luxc/lang/translation/jvm/procedure/common.lux
@@ -3,19 +3,23 @@
    [abstract
     ["." monad (#+ do)]]
    [control
-    ["p" parser]
+    ["<>" parser
+     ["<s>" synthesis (#+ Parser)]]
     ["ex" exception (#+ exception:)]]
    [data
+    ["." product]
+    ["." error]
     ["." text
      format]
     [collection
+     ["." list ("#@." monad)]
      ["." dictionary]]]
    [target
     [jvm
      ["_t" type (#+ Type Method)]]]
    [tool
     [compiler
-     ["." synthesis (#+ Synthesis)]
+     ["." synthesis (#+ Synthesis %synthesis)]
      ["." phase
       [generation
        [extension (#+ Nullary Unary Binary Trinary Variadic
@@ -26,11 +30,24 @@
   [luxc
    [lang
     [host
-     ["$" jvm (#+ Label Inst Bundle)
+     ["$" jvm (#+ Label Inst Def Handler Bundle Operation Phase)
       ["_" inst]]]]]
   ["." ///
    ["." runtime]])
 
+(def: #export (custom [parser handler])
+  (All [s]
+    (-> [(Parser s)
+         (-> Text Phase s (Operation Inst))]
+        Handler))
+  (function (_ extension-name phase input)
+    (case (<s>.run input parser)
+      (#error.Success input')
+      (handler extension-name phase input')
+
+      (#error.Failure error)
+      (phase.throw extension.invalid-syntax [extension-name %synthesis input]))))
+
 (import: java/lang/Double
   (#static MIN_VALUE Double)
   (#static MAX_VALUE Double))
@@ -58,6 +75,47 @@
 
 (def: unitI Inst (_.string synthesis.unit))
 
+## TODO: Get rid of this ASAP
+(def: lux::syntax-char-case!
+  (..custom [($_ <>.and
+                 <s>.any
+                 <s>.any
+                 (<>.some (<s>.tuple ($_ <>.and
+                                         (<s>.tuple (<>.many <s>.i64))
+                                         <s>.any))))
+             (function (_ extension-name phase [input else conditionals])
+               (<| _.with-label (function (_ @end))
+                   _.with-label (function (_ @else))
+                   (do phase.monad
+                     [inputG (phase input)
+                      elseG (phase else)
+                      conditionalsG+ (: (Operation (List [(List [Int Label])
+                                                          Inst]))
+                                        (monad.map @ (function (_ [chars branch])
+                                                       (do @
+                                                         [branchG (phase branch)]
+                                                         (wrap (<| _.with-label (function (_ @branch))
+                                                                   [(list@map (function (_ char)
+                                                                                [(.int char) @branch])
+                                                                              chars)
+                                                                    (|>> (_.label @branch)
+                                                                         branchG
+                                                                         (_.GOTO @end))]))))
+                                                   conditionals))
+                      #let [table (|> conditionalsG+
+                                      (list@map product.left)
+                                      list@join)
+                            conditionalsG (|> conditionalsG+
+                                              (list@map product.right)
+                                              _.fuse)]]
+                     (wrap (|>> inputG (_.unwrap #_t.Long) _.L2I
+                                (_.LOOKUPSWITCH @else table)
+                                conditionalsG
+                                (_.label @else)
+                                elseG
+                                (_.label @end)
+                                )))))]))
+
 (def: (lux::is [referenceI sampleI])
   (Binary Inst)
   (|>> referenceI
@@ -251,6 +309,7 @@
 (def: bundle::lux
   Bundle
   (|> (: Bundle bundle.empty)
+      (bundle.install "syntax char case!" lux::syntax-char-case!)
       (bundle.install "is" (binary lux::is))
       (bundle.install "try" (unary lux::try))))
 
diff --git a/new-luxc/source/luxc/lang/translation/jvm/procedure/host.lux b/new-luxc/source/luxc/lang/translation/jvm/procedure/host.lux
index e57101660..83cbd017b 100644
--- a/new-luxc/source/luxc/lang/translation/jvm/procedure/host.lux
+++ b/new-luxc/source/luxc/lang/translation/jvm/procedure/host.lux
@@ -6,7 +6,7 @@
     ["." exception (#+ exception:)]
     ["<>" parser ("#@." monad)
      ["<t>" text]
-     ["<s>" synthesis]]]
+     ["<s>" synthesis (#+ Parser)]]]
    [data
     ["." product]
     ["." maybe]
@@ -46,25 +46,14 @@
      ["$" jvm (#+ Label Inst Def Handler Bundle Operation Phase)
       ["_" inst]
       ["_." def]]]]]
-  ["." /// #_
-   ["#." reference]
-   ["#." function]])
+  ["." // #_
+   [common (#+ custom)]
+   ["/#" // #_
+    ["#." reference]
+    ["#." function]]])
 
 (exception: #export invalid-syntax-for-argument-generation)
 
-(def: (custom [parser handler])
-  (All [s]
-    (-> [(<s>.Parser s)
-         (-> Text Phase s (Operation Inst))]
-        Handler))
-  (function (_ extension-name phase input)
-    (case (<s>.run input parser)
-      (#error.Success input')
-      (handler extension-name phase input')
-
-      (#error.Failure error)
-      (phase.throw extension.invalid-syntax [extension-name %synthesis input]))))
-
 (template [<name> <inst>]
   [(def: <name>
      Inst
@@ -322,13 +311,14 @@
 
 (def: (primitive-array-length-handler jvm-primitive)
   (-> Type Handler)
-  (..custom [<s>.any
-             (function (_ extension-name generate arrayS)
-               (do phase.monad
-                 [arrayI (generate arrayS)]
-                 (wrap (|>> arrayI
-                            (_.CHECKCAST (jvm.descriptor (jvm.array 1 jvm-primitive)))
-                            _.ARRAYLENGTH))))]))
+  (..custom
+   [<s>.any
+    (function (_ extension-name generate arrayS)
+      (do phase.monad
+        [arrayI (generate arrayS)]
+        (wrap (|>> arrayI
+                   (_.CHECKCAST (jvm.descriptor (jvm.array 1 jvm-primitive)))
+                   _.ARRAYLENGTH))))]))
 
 (def: (array::length::object extension-name generate inputs)
   Handler
@@ -543,18 +533,16 @@
     _
     (phase.throw extension.invalid-syntax [extension-name %synthesis inputs])))
 
-(def: (object::instance? extension-name generate inputs)
+(def: object::instance?
   Handler
-  (case inputs
-    (^ (list (synthesis.text class) objectS))
-    (do phase.monad
-      [objectI (generate objectS)]
-      (wrap (|>> objectI
-                 (_.INSTANCEOF class)
-                 (_.wrap #jvm.Boolean))))
-
-    _
-    (phase.throw extension.invalid-syntax [extension-name %synthesis inputs])))
+  (..custom
+   [($_ <>.and <s>.text <s>.any)
+    (function (_ extension-name generate [class objectS])
+      (do phase.monad
+        [objectI (generate objectS)]
+        (wrap (|>> objectI
+                   (_.INSTANCEOF class)
+                   (_.wrap #jvm.Boolean)))))]))
 
 (def: (object::cast extension-name generate inputs)
   Handler
@@ -813,20 +801,20 @@
           )))
 
 (def: var
-  (<s>.Parser Var)
+  (Parser Var)
   <s>.text)
 
 (def: bound
-  (<s>.Parser Bound)
+  (Parser Bound)
   (<>.or (<s>.constant! ["" ">"])
          (<s>.constant! ["" "<"])))
 
 (def: (class' generic)
-  (-> (<s>.Parser Generic) (<s>.Parser Class))
+  (-> (Parser Generic) (Parser Class))
   (<s>.tuple (<>.and <s>.text (<>.some generic))))
 
 (def: generic
-  (<s>.Parser Generic)
+  (Parser Generic)
   (<>.rec
    (function (_ generic)
      (let [wildcard (<>.or (<s>.constant! ["" "?"])
@@ -837,11 +825,11 @@
            (class' generic))))))
 
 (def: class
-  (<s>.Parser Class)
+  (Parser Class)
   (class' ..generic))
 
 (def: primitive
-  (<s>.Parser Primitive)
+  (Parser Primitive)
   ($_ <>.or
       (<s>.constant! ["" reflection.boolean])
       (<s>.constant! ["" reflection.byte])
@@ -854,7 +842,7 @@
       ))
 
 (def: jvm-type
-  (<s>.Parser Type)
+  (Parser Type)
   (<>.rec
    (function (_ jvm-type)
      ($_ <>.or
@@ -863,28 +851,28 @@
          (<s>.tuple jvm-type)))))
 
 (def: constructor-arg
-  (<s>.Parser (Typed Synthesis))
+  (Parser (Typed Synthesis))
   (<s>.tuple (<>.and ..jvm-type <s>.any)))
 
 (def: annotation-parameter
-  (<s>.Parser (/.Annotation-Parameter Synthesis))
+  (Parser (/.Annotation-Parameter Synthesis))
   (<s>.tuple (<>.and <s>.text <s>.any)))
 
 (def: annotation
-  (<s>.Parser (/.Annotation Synthesis))
+  (Parser (/.Annotation Synthesis))
   (<s>.tuple (<>.and <s>.text (<>.some ..annotation-parameter))))
 
 (def: argument
-  (<s>.Parser Argument)
+  (Parser Argument)
   (<s>.tuple (<>.and <s>.text ..jvm-type)))
 
 (def: return
-  (<s>.Parser Return)
+  (Parser Return)
   (<>.or (<s>.constant! ["" jvm.void-descriptor])
          ..jvm-type))
 
 (def: overriden-method-definition
-  (<s>.Parser [Environment (/.Overriden-Method Synthesis)])
+  (Parser [Environment (/.Overriden-Method Synthesis)])
   (<s>.tuple (do <>.monad
                [ownerT ..class
                 name <s>.text