[Bugs]

- Char pattern-matching is now handled better and defaults now work for it.
- Text pattern-matching is now handled better and defaults now work for it.

3 files changed, 235 insertions, 22 deletions

diff --git a/src/lux/analyser.clj b/src/lux/analyser.clj
index b192a2e31..07d3fb3b7 100644
--- a/src/lux/analyser.clj
+++ b/src/lux/analyser.clj
@@ -609,6 +609,17 @@
 
 (let [fold-branch (fn [struct entry]
                     (let [struct* (clojure.core.match/match (nth entry 0)
+                                    [::pm-char ?token]
+                                    (clojure.core.match/match (:type struct)
+                                      ::char-tests (update-in struct [:patterns ?token] (fn [bodies]
+                                                                                          (if bodies
+                                                                                            (conj bodies (nth entry 1))
+                                                                                            #{(nth entry 1)})))
+                                      nil (-> struct
+                                              (assoc :type ::char-tests)
+                                              (assoc-in [:patterns ?token] #{(nth entry 1)}))
+                                      _ (assert false "Can't do match."))
+
                                     [::pm-text ?text]
                                     (clojure.core.match/match (:type struct)
                                       ::text-tests (update-in struct [:patterns ?text] (fn [bodies]
@@ -676,6 +687,7 @@
                             ;; (.print System/out (prn-str 'branches* branches*))
                             ;; (.print System/out (prn-str '(:type branches*) (:type branches*)))
                             (clojure.core.match/match (:type branches*)
+                              ::char-tests branches*
                               ::text-tests branches*
                               ::tuple (do (assert (<= (count (:defaults branches*)) 1))
                                         {:type ::tuple*
@@ -710,6 +722,9 @@
                                    :branches (:branches branches*)})))
       get-vars (fn get-vars [pattern]
                  (clojure.core.match/match pattern
+                   [::&parser/char ?token]
+                   '()
+
                    [::&parser/text ?text]
                    '()
 
@@ -730,6 +745,9 @@
                    ))
       ->instructions (fn ->instructions [locals pattern]
                        (clojure.core.match/match pattern
+                         [::&parser/char ?token]
+                         [::pm-char ?token]
+
                          [::&parser/text ?text]
                          [::pm-text ?text]
 
@@ -801,6 +819,14 @@
            [registers mappings tree] (exec [=branches (map-m (fn [[?pattern ?body]]
                                                                ;; (prn '?branch ?branch)
                                                                (match ?pattern
+                                                                 [::&parser/char ?token]
+                                                                 (exec [=body (analyse-form* ?body)]
+                                                                   (return [::case-branch [::&parser/char ?token] =body]))
+
+                                                                 [::&parser/text ?token]
+                                                                 (exec [=body (analyse-form* ?body)]
+                                                                   (return [::case-branch [::&parser/text ?token] =body]))
+                                                                 
                                                                  [::&parser/ident ?name]
                                                                  (exec [=body (with-locals {?name (annotated [::local $scope $base] [::&type/object "java.lang.Object" []])}
                                                                                 (analyse-form* ?body))]
diff --git a/src/lux/compiler.clj b/src/lux/compiler.clj
index 5b257eaed..ae8c75aa0 100644
--- a/src/lux/compiler.clj
+++ b/src/lux/compiler.clj
@@ -318,17 +318,38 @@
   (defn compile-decision-tree [writer mappings default-label decision-tree]
     ;; (prn 'compile-decision-tree decision-tree)
     (match decision-tree
-      [::test-text ?text $body]
-      (let [$else (new Label)]
+      [::test-char ?pairs]
+      (do (doseq [[?token $body] ?pairs
+                  :let [$else (new Label)]]
+            (doto writer
+              ;; object
+              (.visitInsn Opcodes/DUP) ;; object, object
+              (.visitTypeInsn Opcodes/NEW (->class "java.lang.Character"))
+              (.visitInsn Opcodes/DUP)
+              (.visitLdcInsn ?token) ;; object, object, text
+              (.visitMethodInsn Opcodes/INVOKESPECIAL (->class "java.lang.Character") "<init>" "(C)V")
+              (.visitMethodInsn Opcodes/INVOKEVIRTUAL oclass "equals" equals-sig) ;; object, B
+              (.visitJumpInsn Opcodes/IFEQ $else) ;; object
+              (.visitInsn Opcodes/POP)
+              (.visitJumpInsn Opcodes/GOTO (get mappings $body))
+              (.visitLabel $else)))
         (doto writer
-          ;; object
-          (.visitInsn Opcodes/DUP) ;; object, object
-          (.visitLdcInsn ?text) ;; object, object, text
-          (.visitMethodInsn Opcodes/INVOKEVIRTUAL oclass "equals" equals-sig) ;; object, B
-          (.visitJumpInsn Opcodes/IFEQ $else) ;; object
           (.visitInsn Opcodes/POP)
-          (.visitJumpInsn Opcodes/GOTO (get mappings $body))
-          (.visitLabel $else)
+          (.visitJumpInsn Opcodes/GOTO default-label)))
+      
+      [::test-text ?pairs]
+      (do (doseq [[?text $body] ?pairs
+                  :let [$else (new Label)]]
+            (doto writer
+              ;; object
+              (.visitInsn Opcodes/DUP) ;; object, object
+              (.visitLdcInsn ?text) ;; object, object, text
+              (.visitMethodInsn Opcodes/INVOKEVIRTUAL oclass "equals" equals-sig) ;; object, B
+              (.visitJumpInsn Opcodes/IFEQ $else) ;; object
+              (.visitInsn Opcodes/POP)
+              (.visitJumpInsn Opcodes/GOTO (get mappings $body))
+              (.visitLabel $else)))
+        (doto writer
           (.visitInsn Opcodes/POP)
           (.visitJumpInsn Opcodes/GOTO default-label)))
 
@@ -427,12 +448,24 @@
                            ]
                        [[::store ?local ?body] #{?body}])
 
+                     ::&analyser/char-tests
+                     (concat (list [[::test-char (for [[?token ?supports] (:patterns head)
+                                                       ?body (set/intersection branches ?supports)
+                                                       ;; :when (set/subset? branches ?supports)
+                                                       ]
+                                                   [?token ?body])]
+                                    branches])
+                             (for [[_ ?local ?body] (:defaults head)
+                                   :when (contains? branches ?body)]
+                               [[::store ?local ?body] #{?body}]))
+
                      ::&analyser/text-tests
-                     (concat (for [[?text ?supports] (:patterns head)
-                                   ?body (set/intersection branches ?supports)
-                                   ;; :when (set/subset? branches ?supports)
-                                   ]
-                               [[::test-text ?text ?body] #{?body}])
+                     (concat (list [[::test-text (for [[?token ?supports] (:patterns head)
+                                                       ?body (set/intersection branches ?supports)
+                                                       ;; :when (set/subset? branches ?supports)
+                                                       ]
+                                                   [?token ?body])]
+                                    branches])
                              (for [[_ ?local ?body] (:defaults head)
                                    :when (contains? branches ?body)]
                                [[::store ?local ?body] #{?body}]))
@@ -519,6 +552,7 @@
     [::&analyser/case ?base-idx ?variant ?max-registers ?branch-mappings ?decision-tree]
     (do ;; (prn 'compile-case ?base-idx ?variant ?max-registers ?branch-mappings ?decision-tree)
         ;; (assert false)
+        ;; (prn 'compile-case ?decision-tree)
         (let [start-label (new Label)
               end-label (new Label)
               ;; default-label (new Label)
@@ -539,24 +573,28 @@
             ;; (prn 'sequence-parts
             ;;      (sequence-parts (:branches ?decision-tree) (list ?decision-tree)))
             (doseq [decision-tree (let [pieces (map first (sequence-parts (:branches ?decision-tree) (list ?decision-tree)))]
-                                    (if (:default ?decision-tree)
+                                    (if (or (:default ?decision-tree)
+                                            (not (empty? (:defaults ?decision-tree))))
                                       (butlast pieces)
                                       pieces))]
               (compile-decision-tree *writer* mappings* default-label decision-tree))
             (.visitLabel *writer* default-label)
-            (if-let [[_ [_ _ ?idx] ?body] (:default ?decision-tree)]
+            (if-let [[_ [_ _ ?idx] ?body] (or (:default ?decision-tree)
+                                              (first (:defaults ?decision-tree)))]
               (doto *writer*
                 (.visitInsn Opcodes/DUP)
                 (.visitVarInsn Opcodes/ASTORE ?idx)
                 (.visitJumpInsn Opcodes/GOTO (get mappings* ?body)))
               (doto *writer*
-                ;; (.visitInsn Opcodes/POP)
-                (.visitTypeInsn Opcodes/CHECKCAST (->class +variant-class+))
-                (.visitFieldInsn Opcodes/GETFIELD (->class +variant-class+) "tag" (->type-signature "java.lang.String"))
+                (.visitInsn Opcodes/POP)
+                ;; (.visitTypeInsn Opcodes/CHECKCAST (->class +variant-class+))
+                ;; (.visitFieldInsn Opcodes/GETFIELD (->class +variant-class+) "tag" (->type-signature "java.lang.String"))
                 (.visitTypeInsn Opcodes/NEW ex-class)
-                (.visitInsn Opcodes/DUP_X1)
-                (.visitInsn Opcodes/SWAP)
-                (.visitMethodInsn Opcodes/INVOKESPECIAL ex-class "<init>" (str "(" (->type-signature "java.lang.String") ")" "V"))
+                (.visitInsn Opcodes/DUP)
+                ;; (.visitInsn Opcodes/DUP_X1)
+                ;; (.visitInsn Opcodes/SWAP)
+                (.visitMethodInsn Opcodes/INVOKESPECIAL ex-class "<init>" "()V")
+                ;; (.visitMethodInsn Opcodes/INVOKESPECIAL ex-class "<init>" (str "(" (->type-signature "java.lang.String") ")" "V"))
                 (.visitInsn Opcodes/ATHROW)))
             ;; (if default-code
             ;;   ;; (do (prn 'default-code default-code)
diff --git a/test2.lux b/test2.lux
index e5e3ad6da..c3854ab19 100644
--- a/test2.lux
+++ b/test2.lux
@@ -269,6 +269,103 @@
            outputs (map-m f inputs')]
       (return (#Cons output outputs)))))
 
+(def (fold-m f init inputs)
+  (case inputs
+    #Nil              (return init)
+    (#Cons x inputs') (exec [init* (f init x)]
+                        (fold-m f init* inputs'))))
+
+(def (apply-m monad call-state)
+  (lambda [state]
+     (let output (monad call-state)
+          (case output
+            (#Ok [?state ?datum])
+            (#Ok [state ?datum])
+
+            _
+            output))))
+
+(def (assert test message)
+  (if test
+    (return [])
+    (fail message)))
+
+(def (pass %value)
+  (lambda [state]
+     %value))
+
+(def get-state
+  (lambda [state]
+     (return* state state)))
+
+(def (show x)
+  (jvm/invokevirtual Object "toString" []
+                     x []))
+
+(def (concat t1 t2)
+  (jvm/invokevirtual String "concat" [String]
+                     t1 [t2]))
+
+(def (normalize-char char)
+  (case char
+    #"*" "_ASTER_"
+    #"+" "_PLUS_"
+    #"-" "_DASH_"
+    #"/" "_SLASH_"
+    #"_" "_UNDERS_"
+    #"%" "_PERCENT_"
+    #"$" "_DOLLAR_"
+    #"'" "_QUOTE_"
+    #"`" "_BQUOTE_"
+    #"@" "_AT_"
+    #"^" "_CARET_"
+    #"&" "_AMPERS_"
+    #"=" "_EQ_"
+    #"!" "_BANG_"
+    #"?" "_QM_"
+    #":" "_COLON_"
+    #";" "_SCOLON_"
+    #"." "_PERIOD_"
+    #"," "_COMMA_"
+    #"<" "_LT_"
+    #">" "_GT_"
+    #"~" "_TILDE_"
+    ##;;#"\" "_BSLASH_"
+    _    (show char)
+    ))
+
+(def (range from to)
+  (if (= to from)
+    #Nil
+    (#Cons from (range (inc from) to))))
+
+#(
+  (def (text->list text)
+    (let length (jvm/invokevirtual String "length" []
+                                   text [])
+         (map (lambda [idx]
+                 (jvm/invokevirtual String "charAt" [int]
+                                    text [idx]))
+              (range-to 0 length))))
+
+  (def (normalize-ident ident)
+    (fold concat "" (map normalize-char (text->list ident))))
+
+  (def (fresh-class-loader path)
+    (let file (jvm/new java.io.File [String] [path])
+         (let url (jvm/invokevirtual java.io.File "toURL" []
+                                     file [])
+              (let urls (array java.net.URL (list url))
+                   (jvm/new java.net.URLClassLoader [(Array java.net.URL)] [urls])))))
+
+  (def (fresh-class-loader path)
+    (let [file (jvm/new java.io.File [String] [path])
+          url (jvm/invokevirtual java.io.File "toURL" []
+                                 file [])
+          urls (array java.net.URL (list url))]
+      (jvm/new java.net.URLClassLoader [(Array java.net.URL)] [urls])))
+  )#
+
 (def (cons tail head)
   (#Cons head tail))
 
@@ -307,6 +404,53 @@
 (def (run-state monad state)
   (monad state))
 
+(def list-map #Nil)
+
+(def (put key val map)
+  (case map
+    #Nil
+    (#Cons [key val] map)
+
+    (#Cons [?key ?val] map')
+    (if (= key ?key)
+      (#Cons [?key val] map')
+      (#Cons [?key ?val] (put key val map')))))
+
+(def (get key map)
+  (case map
+    #Nil
+    #None
+    
+    (#Cons [?key ?val] map')
+    (if (= key ?key)
+      (#Some ?val)
+      (get key map'))))
+
+(def (show-kv kv)
+  (case kv
+    [?key ?val]
+    (fold concat "" (list "#" ?key " " (show ?val)))))
+
+(def (interpose elem list)
+  (case list
+    (#Cons x (#Cons y list'))
+    (#Cons x (#Cons elem (#Cons y list')))
+
+    _
+    list))
+
+(def (print-map list-map)
+  (do (print "{")
+    (print (fold concat "" (interpose " " (map show-kv list-map))))
+    (println "}")))
+
+(def (show-list xs)
+  (case xs
+    #Nil
+    "#Nil"
+    (#Cons x xs')
+    (fold concat "" (list "(#Cons " (show x) " " (show-list xs') ")"))))
+
 ## Program
 (def (main args)
   (case (' ((~ "Oh yeah...")))
@@ -333,6 +477,11 @@
         (#Failure ?message)
         (println ?message))
       (print-enum (enumerate (list #"a" #"b" #"c" #"d" #"e")))
+      (print-map (put "Nyan" "cat" (put "Yolo" "lol" list-map)))
+      (let char #"*"
+           (do (print (show char)) (print " -> ")
+               (println (normalize-char char))))
+      (println (show-list (range 0 10)))
       )
     ))