From a420abd8ef1d5a008a5a0b6f75590cab2a9baac5 Mon Sep 17 00:00:00 2001
From: Eduardo Julian
Date: Tue, 28 May 2019 18:43:43 -0400
Subject: Implemented machinery for "lux syntax char case!".

---
 .../luxc/lang/translation/jvm/procedure/common.lux | 65 +++++++++++++++++++++-
 1 file changed, 62 insertions(+), 3 deletions(-)

(limited to 'new-luxc/source/luxc/lang/translation/jvm/procedure/common.lux')

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))))
 
-- 
cgit v1.2.3