Skip to content
This repository

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse code

* src/main/clojure/clojure/core/match.clj: MATCH-45: group like patte…

…rns together, prevents many suprising ordering issues.
  • Loading branch information...
commit 29607a2105d8af90c5b8d9d4cde9191e63a2570c 1 parent 0c53c36
David Nolen authored December 23, 2011
93  src/main/clojure/clojure/core/match.clj
@@ -526,30 +526,26 @@
526 526
   "Case 3a: The first column is chosen. Compute and return a switch/bind node
527 527
   with a default matrix case"
528 528
   [this col ocrs]
529  
-  (letfn [(pseudo-patterns [this i]
530  
-            (->> (column this i)
  529
+  (letfn [(pseudo-patterns [matrix i]
  530
+            (->> (column matrix i)
531 531
               (filter pseudo-pattern?)))
532 532
           
533  
-          (default-matrix 
534  
-            [this]
535  
-            (let [m (pattern-matrix (into [] (drop-while #(not (wildcard-pattern? (first %)))
536  
-                                                         (rows this)))
537  
-                                    (occurrences this))]
  533
+          (default-matrix  [matrix]
  534
+            (let [m (pattern-matrix
  535
+                     (into []
  536
+                       (drop-while #(not (wildcard-pattern? (first %)))
  537
+                                   (rows matrix)))
  538
+                     (occurrences matrix))]
538 539
               (if-not (empty-matrix? m)
539  
-                (do (trace-dag "Add specialized matrix on row of wildcards as default matrix for next node")
  540
+                (do
  541
+                  (trace-dag (str "Add specialized matrix on row of "
  542
+                                  "wildcards as default matrix for next node"))
540 543
                   (compile m))
541 544
                 (do 
542  
-                  (trace-dag "Add fail-node as default matrix for next node (specialized matrix empty)")
  545
+                  (trace-dag (str "Add fail-node as default matrix for next "
  546
+                                  "node (specialized matrix empty)"))
543 547
                   (fail-node)))))
544 548
 
545  
-          (group-patterns [ps]
546  
-            (let [[l r] (split-with #(not (wildcard-pattern? %)) ps)]
547  
-              (letfn [(group [[p & prs :as ps]]
548  
-                        (if (seq ps)
549  
-                          (let [[fs rs] ((juxt filter remove) #(= (type p) (type %)) prs)]
550  
-                            (concat (cons p fs) (group rs)))))]
551  
-                (concat (group l) r))))
552  
-
553 549
           (group-rows [rows]
554 550
             (let [[l r] (split-with #(not (wildcard-pattern? (first %))) rows)]
555 551
               (letfn [(group [[r & rs :as rows]]
@@ -580,43 +576,30 @@
580 576
                         (conj a b)))
581 577
                     [] ps))
582 578
 
583  
-          (column-constructors 
584  
-            ;; Returns a vector of relevant constructors in column i of matrix this
585  
-            [this i]
586  
-            (let [ps (group-vector-patterns (group-patterns (column this i)))
587  
-                  ps (take-while (comp not wildcard-pattern?) ps)]
588  
-              (collapse ps)))
589  
-
590  
-          ;; (column-constructors 
591  
-          ;;   ;; Returns a vector of relevant constructors in column i of matrix this
592  
-          ;;   [col i]
593  
-          ;;   (let [cs (group-vector-patterns col)]
594  
-          ;;     (collapse (take-while (comp not wildcard-pattern?) cs))))
595  
-
596  
-          (switch-clauses 
597  
-            ;; Compile a decision trees for each constructor cs and returns a clause list
598  
-            ;; usable by a switch node
599  
-            [this cs]
  579
+          ;; Returns a vector of relevant constructors in column i of matrix
  580
+          (column-constructors [matrix i]
  581
+            (let [cs (group-vector-patterns (column matrix i))]
  582
+              (collapse (take-while (comp not wildcard-pattern?) cs))))
  583
+
  584
+          ;; Compile a decision trees for each constructor cs and returns a clause list
  585
+          ;; usable by a switch node
  586
+          (switch-clauses [matrix cs]
600 587
             (into []
601  
-                  (map (fn [c rows]
602  
-                         (let [s (-> this 
603  
-                                   (specialize c rows (occurrences this)) 
604  
-                                   compile)]
605  
-                           [c s]))
606  
-                       cs (loop [[c :as cs] (seq cs) grouped [] rows (rows this)]
607  
-                            (if (nil? cs)
608  
-                              grouped
609  
-                              (let [[l r] (split-with #(pattern-equals c (first %)) rows)]
610  
-                                (recur (next cs) (conj grouped l) r)))))))
  588
+              (map (fn [c rows]
  589
+                     (let [s (-> matrix
  590
+                                 (specialize c rows (occurrences matrix)) 
  591
+                                 compile)]
  592
+                       [c s]))
  593
+                   cs (loop [[c :as cs] (seq cs) grouped [] rows (rows matrix)]
  594
+                        (if (nil? cs)
  595
+                          grouped
  596
+                          (let [[l r] (split-with #(pattern-equals c (first %)) rows)]
  597
+                            (recur (next cs) (conj grouped l) r)))))))
611 598
 
612 599
           (switch-or-bind-node [col ocrs clauses default]
613  
-            (letfn [(expression? 
614  
-                      ;; Returns true if occurrence ocr is an expression
615  
-                      [ocr] 
  600
+            (letfn [(expression? [ocr] 
616 601
                       (contains? (meta ocr) :ocr-expr))
617  
-                    (bind-variables 
618  
-                      ;; Return bindings usable by bind-node
619  
-                      [ocrs] 
  602
+                    (bind-variables [ocrs] 
620 603
                       (mapcat (fn [ocr]
621 604
                                 (let [bind-expr (get (meta ocr) :ocr-expr ::not-found)]
622 605
                                   (if (not= bind-expr ::not-found)
@@ -632,13 +615,13 @@
632 615
                 (let [o (ocrs col)
633 616
                       _ (trace-dag "Add switch-node on occurrence " o)]
634 617
                   (switch-node o clauses default)))))]
635  
-    (let [;; rows (group-rows rows)
636  
-          this (reduce (fn [matrix p]
  618
+    (let [exp-matrix (reduce (fn [matrix p]
637 619
                          (specialize matrix p (rows matrix) (occurrences matrix)))
638 620
                        this (pseudo-patterns this col))
639  
-          constrs (column-constructors this col) ;; (column-constructors (map first rows))
640  
-          clauses (switch-clauses this constrs)
641  
-          default (default-matrix this)
  621
+          new-matrix (pattern-matrix (group-rows (rows exp-matrix)) (occurrences exp-matrix))
  622
+          constrs (column-constructors new-matrix col)
  623
+          clauses (switch-clauses new-matrix constrs)
  624
+          default (default-matrix new-matrix)
642 625
           _ (trace-dag "Column" col ":" constrs)]
643 626
       (switch-or-bind-node col ocrs clauses default))))
644 627
 
26  src/test/clojure/clojure/core/match/test/core.clj
@@ -562,12 +562,32 @@
562 562
            :else :a4)
563 563
          :a0)))
564 564
 
565  
-;; FIXME
566  
-#_(deftest match-group-type-1
  565
+(deftest match-order-6
567 566
   (is (= (match [[2]]
568 567
            [[1]] :a0
569 568
            [1] :a1
570 569
            [[2]] :a2
571 570
            [2] :a3
572 571
            :else :a4)
573  
-         :a0)))
  572
+         :a2)))
  573
+
  574
+(deftest match-order-6-recur
  575
+  (is (= ((fn [x done]
  576
+            (if done
  577
+              done
  578
+              (match [x]
  579
+                [[1]] (recur x :a0)
  580
+                [1] (recur x :a1)
  581
+                [[2]] (recur x :a2)
  582
+                [2] (recur x :a3)
  583
+                :else :a4))) [2] false)
  584
+         :a2)))
  585
+
  586
+(deftest match-order-7
  587
+  (is (= (match [[2]]
  588
+           [1] :a0
  589
+           [[1]] :a1
  590
+           [2] :a2
  591
+           [[2]] :a3
  592
+           :else :a4)
  593
+         :a3)))

0 notes on commit 29607a2

Please sign in to comment.
Something went wrong with that request. Please try again.