Implemented machinery for "lux syntax char case!".

2 files changed, 98 insertions, 51 deletions

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