Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Fetching contributors…

Cannot retrieve contributors at this time

1771 lines (1506 sloc) 61.62 kB
(ns clojure.core.match
(:refer-clojure :exclude [compile])
(:require [clojure.set :as set])
(:import [java.io Writer]))
;; # Introduction
;;
;; This namespace contains an implementation of closed pattern matching. It uses
;; an algorithm based on Luc Maranget's paper "Compiling Pattern Matching to Good Decision Trees".
;;
;; There are three main steps to this implementation:
;;
;; 1. *Converting Clojure syntax to a Pattern Matrix*:
;; The function `emit-matrix` does this work.
;; A Pattern Matrix is represented by PatternMatrix.
;;
;; 2. *Compiling the Pattern Matrix to a Directed Acyclic Graph*:
;; The function `compile` does this work. This step
;; is where Maranget's algorithm is implemented.
;;
;; 3. *Converting the DAG to Clojure code*:
;; This is mostly a 1-1 conversion. See function `executable-form`.
;;
;; # Nomenclature
;;
;; * x and y are called _occurrences_
;; * 1, 2, 3 and 4 are _patterns_
;; * [1 2] and [3 4] are _pattern rows_
;; * :a0 and :a1 are _actions_
;;
(comment
(match [x y]
[1 2] :a0
[3 4] :a1))
;; ============================================
;; # Debugging tools
;;
;; These debugging aids are most useful in steps 2 and 3 of compilation.
;;
;; TODO allow these to be set dynamically, at macro-expand time.
;; Maybe match macros could take extra metadata? - Ambrose
(def ^{:dynamic true
:doc "Enable syntax check of match macros"}
*syntax-check* (atom true))
(def ^{:dynamic true
:doc "Enable breadcrumb diagnostics with fail nodes"}
*breadcrumbs* (atom true))
(def ^{:dynamic true
:doc "Enable pattern compile time tracing"}
*trace* (atom false))
(def ^{:dynamic true
:doc "Enable backtracking diagnostics"}
*backtrack-with-errors* (atom false))
(def ^{:dynamic true}
*clojurescript* false)
(def ^{:dynamic true} *line*)
(def ^{:dynamic true} *locals* nil)
(def ^{:dynamic true} *warned*)
(def ^{:dynamic true} *vector-type* ::vector)
(def ^{:dynamic true} *match-breadcrumbs* [])
(def ^{:dynamic true} *recur-present* false)
(defn set-trace! [b]
(reset! *trace* b))
(defn set-breadcrumbs! [b]
(reset! *breadcrumbs* b))
(def backtrack (Exception. "Could not find match."))
(defn backtrack-expr []
(if *clojurescript*
`(throw clojure.core.match/backtrack)
`(throw clojure.core.match/backtrack)))
(defn warn [msg]
(if (not @*warned*)
(do
(binding [*out* *err*]
(println "WARNING:"
(str *ns* ", line " *line* ":")
msg))
(reset! *warned* true))))
(defn trace-matrix [& p]
(when @*trace*
(apply println "TRACE: MATRIX:" p)
(flush)))
(defn trace-dag [& p]
(when @*trace*
(apply println "TRACE: DAG:" p)
(flush)))
;; =============================================================================
;; # Protocols
(defprotocol ISpecializeMatrix
(specialize-matrix [this rows ocrs]))
(defprotocol IPatternContainer
(pattern [this]))
(defprotocol IContainsRestPattern
(contains-rest-pattern? [this]))
(defprotocol IMatchLookup
"Allows arbitrary objects to act like a map-like object when pattern
matched. Avoid extending this directly for Java Beans, see
`match.java/bean-match`."
(val-at [this k not-found]))
;; =============================================================================
;; # Map Pattern Interop
(extend-type clojure.lang.ILookup
IMatchLookup
(val-at [this k not-found]
(.valAt this k not-found)))
(defn val-at*
([m k] (let [val (val-at m k ::not-found)]
(if (= val ::not-found)
(throw backtrack)
val)))
([m k not-found] (val-at m k not-found)))
(defn val-at-expr [& args]
(if *clojurescript* ;;then we need to inline the correct behavior
(if (= 3 (count args))
`(get ~@args)
(let [[m k] args]
`(let [val# (get ~m ~k ::not-found)]
(if (= val# ::not-found)
(throw 0)
val#))))
;;If not ClojureScript, defer to val-at*
`(val-at* ~@args)))
;; =============================================================================
;; # Vector Pattern Interop
(defn vector-type [t & r] t)
(defmulti check-size? identity)
(defmulti tag (fn [t] t))
(defmulti test-inline vector-type)
(defmulti test-with-size-inline vector-type)
(defmulti count-inline vector-type)
(defmulti nth-inline vector-type)
(defmulti nth-offset-inline vector-type)
(defmulti subvec-inline vector-type)
(defmulti nthnext-inline vector-type)
(defmethod check-size? :default
[_] true)
(defmethod tag :default
[t] (throw (Exception. (str "No tag specified for vector specialization " t))))
(defmethod tag ::vector
[_] clojure.lang.IPersistentVector)
(defn with-tag [t ocr]
(let [the-tag (tag t)
the-tag (if (.isArray ^Class the-tag)
(.getName ^Class the-tag)
the-tag)]
(with-meta ocr (assoc (ocr meta) :tag the-tag))))
(defmethod test-inline ::vector
[t ocr] (if (= t ::vector)
`(vector? ~ocr)
`(instance? ~(tag t) ~ocr)))
(defmethod test-with-size-inline ::vector
[t ocr size] `(and ~(test-inline t ocr) (= ~(count-inline t (with-tag t ocr)) ~size)))
(defmethod count-inline ::vector
[_ ocr] `(count ~ocr))
(defmethod nth-inline ::vector
[_ ocr i] `(nth ~ocr ~i))
(defmethod nth-offset-inline ::vector
[t ocr i offset]
(nth-inline t ocr i))
(defmethod subvec-inline ::vector
([_ ocr start] `(subvec ~ocr ~start))
([_ ocr start end] `(subvec ~ocr ~start ~end)))
(defmethod nthnext-inline ::vector
([_ ocr n] `(nthnext ~ocr ~n)))
;; =============================================================================
;; # Extensions and Protocols
;; TODO: consider converting to multimethods to avoid this nonsense - David
(defprotocol INodeCompile
(n-to-clj [this]))
(defprotocol IPatternCompile
(to-source* [this ocr]))
(defprotocol IVecMod
(prepend [this x])
(drop-nth [this n])
(swap [this n]))
(extend-type clojure.lang.IPersistentVector
IVecMod
(prepend [this x]
(into [x] this))
(drop-nth [this n]
(into (subvec this 0 n)
(subvec this (clojure.core/inc n) (count this))))
(swap [this n]
(let [x (nth this n)]
(prepend (drop-nth this n) x))))
;; -----------------------------------------------------------------------------
;; constructor?
(declare wildcard-pattern?)
(defn constructor? [p]
(not (wildcard-pattern? p)))
;; =============================================================================
;; # Pattern Comparison
;;
;; Used to determine the set of constructors presents in a column and the
;; order which they should be considered
;; FIXME: we use 1 instead of -1, this means we probably have a reverse
;; somehwere - David
(defmulti pattern-compare
"Like `clojure.core/compare` but for comparing patterns"
(fn [a b] [(type a) (type b)]))
(defn pattern-equals [a b]
(zero? (pattern-compare a b)))
(defmethod pattern-compare :default
[a b] (if (= (class a) (class b)) 0 1))
(defmulti safe-pattern-compare
"Like pattern-compare but not affected by *recur-present*"
(fn [a b] [(type a) (type b)]))
(defmethod safe-pattern-compare :default
[a b] (pattern-compare a b))
(defmulti comparable?
"Returns true if it is possible to tell at compile time whether two
different versions of the same object can never match the same
object."
type)
(defmethod comparable? :default
[x]
true)
;; =============================================================================
;; # Pattern Rows
(defprotocol IPatternRow
(action [this])
(patterns [this])
(update-pattern [this i p])
(bindings [this])
(all-wildcards? [this])
(drop-nth-bind [this n bind-expr])) ;; TODO: needs better name - David
(declare leaf-bind-expr named-wildcard-pattern? sym)
(deftype PatternRow [ps action bindings]
IPatternRow
(action [_] action)
(patterns [_] ps)
(update-pattern [_ i p]
(PatternRow. (assoc ps i p) action bindings))
(bindings [_] bindings)
(all-wildcards? [this]
(every? wildcard-pattern? ps))
(drop-nth-bind [this n ocr]
(let [p (ps n)
bind-expr (leaf-bind-expr ocr)
bindings (or bindings [])
bindings (if-let [sym (-> p meta :as)]
(conj bindings [sym bind-expr])
bindings)
bindings (if (named-wildcard-pattern? p)
(conj bindings [(sym p) bind-expr])
bindings)]
(PatternRow. (drop-nth ps n) action
bindings)))
IVecMod
(drop-nth [_ n]
(PatternRow. (drop-nth ps n) action bindings))
(prepend [_ x]
(PatternRow. (into [x] ps) action bindings))
(swap [_ n]
(PatternRow. (swap ps n) action bindings))
clojure.lang.Associative
(assoc [this k v]
(PatternRow. (assoc ps k v) action bindings))
clojure.lang.Indexed
(nth [_ i]
(nth ps i))
(nth [_ i x]
(nth ps i x))
clojure.lang.ISeq
(first [_] (first ps))
(next [_]
(if-let [nps (next ps)]
(PatternRow. nps action bindings)
(PatternRow. [] action bindings)))
(more [_]
(if (empty? ps)
nil
(let [nps (rest ps)]
(PatternRow. nps action bindings))))
(seq [this]
(seq ps))
(count [_]
(count ps))
clojure.lang.IFn
(invoke [_ n]
(nth ps n))
clojure.lang.IPersistentCollection
(cons [_ x]
(PatternRow. (conj ps x) action bindings)))
(defn ^PatternRow pattern-row
([ps action]
{:pre [(vector? ps)]}
(PatternRow. ps action nil))
([ps action bindings]
{:pre [(vector? ps)]} ;; TODO: what can we expect bindings? (or (nil? bindings) (list? bindings)) ? - Ambrose
(PatternRow. ps action bindings)))
;; =============================================================================
;; # Compilation Nodes
;; -----------------------------------------------------------------------------
;; ## Leaf Node
(defrecord LeafNode [value bindings]
INodeCompile
(n-to-clj [this]
(if (not (empty? bindings))
(let [bindings (remove (fn [[sym _]] (= sym '_))
bindings)]
`(let [~@(apply concat bindings)]
~value))
value)))
(defn ^LeafNode leaf-node
([value] (LeafNode. value []))
([value bindings] (LeafNode. value bindings))) ;; TODO precondition on bindings? see above - Ambrose
(defmulti leaf-bind-expr (fn [ocr] (-> ocr meta :occurrence-type)))
(defmethod leaf-bind-expr :seq
[ocr] (-> ocr meta :bind-expr))
(defmethod leaf-bind-expr ::vector
[ocr] (-> ocr meta :bind-expr))
(defmethod leaf-bind-expr :map
[ocr] (let [m (meta ocr)]
(val-at-expr (:map-sym m) (:key m))))
(defmethod leaf-bind-expr :default
[ocr] ocr)
;; -----------------------------------------------------------------------------
;; ## Fail Node
(defmacro error [& body]
(if *clojurescript*
`(js/Error. ~@body)
`(Exception. ~@body)))
(defrecord FailNode []
INodeCompile
(n-to-clj [this]
(if *recur-present*
(if @*breadcrumbs*
`(throw (error (str "No match found. "
"Followed " ~(count *match-breadcrumbs*) " branches."
" Breadcrumbs: " '~*match-breadcrumbs*)))
`(throw (error (str "No match found."))))
(backtrack-expr))))
(defn ^FailNode fail-node []
(FailNode.))
;; -----------------------------------------------------------------------------
;; ## Bind Node
(defrecord BindNode [bindings node]
INodeCompile
(n-to-clj [this]
`(let [~@bindings]
~(n-to-clj node))))
(defn ^BindNode bind-node [bindings node]
(BindNode. bindings node))
;; -----------------------------------------------------------------------------
;; ## Switch Node
(declare to-source)
(defn dag-clause-to-clj [occurrence pattern action]
(let [test (if (instance? clojure.core.match.IPatternCompile pattern)
(to-source* pattern occurrence)
(to-source pattern occurrence))]
(if @*breadcrumbs*
(binding [*match-breadcrumbs* (conj *match-breadcrumbs* test)]
[test (n-to-clj action)])
[test (n-to-clj action)])))
(defn catch-error [& body]
(if *clojurescript*
`(catch js/Error e#
(if (identical? e# clojure.core.match/backtrack)
(do
~@body)
(throw e#)))
`(catch Exception e#
(if (identical? e# clojure.core.match/backtrack)
(do
~@body)
(throw e#)))))
(defrecord SwitchNode [occurrence cases default]
INodeCompile
(n-to-clj [this]
(let [clauses (doall (mapcat (partial apply dag-clause-to-clj occurrence) cases))
bind-expr (-> occurrence meta :bind-expr)
cond-expr (if *recur-present*
(doall (concat `(cond ~@clauses)
`(:else ~(n-to-clj default))))
(doall (concat `(cond ~@clauses)
`(:else ~(if @*backtrack-with-errors*
`(throw (Exception. (str "Could not match" ~occurrence)))
(backtrack-expr))))))]
(if *recur-present*
(if bind-expr
`~(doall (concat `(let [~occurrence ~bind-expr]) (list cond-expr)))
`~cond-expr)
(if bind-expr
`(try ~(doall (concat `(let [~occurrence ~bind-expr]) (list cond-expr)))
~(catch-error (n-to-clj default)))
`(try ~cond-expr
~(catch-error (n-to-clj default))))))))
(defn ^SwitchNode switch-node
([occurrence cases default]
{:pre [(sequential? cases)]}
(SwitchNode. occurrence cases default)))
;; =============================================================================
;; # Pattern Matrix
(defn seq-occurrence? [ocr]
(= (-> ocr meta :occurrence-type) :seq))
(defn map-occurrence? [ocr]
(= (-> ocr meta :occurrence-type) :map))
(defprotocol IPatternMatrix
(width [this])
(height [this])
(dim [this])
(specialize [this c rows ocrs])
(compile [this])
(pattern-at [this i j])
(column [this i])
(row [this j])
(rows [this])
(insert-row [this i row])
(insert-rows [this i rows])
(necessary-column [this])
(useful-matrix [this])
(select [this])
(occurrences [this])
(action-for-row [this j]))
(declare empty-matrix? useful-p? useful?)
;; # Compilation Cases
;;
;; These are analogous to Maranget's Compilation Scheme on page 4, respectively
;; case 1, 2, 2 (also), 3a and 3b.
;;
(defn- empty-rows-case
"Case 1: If there are no pattern rows to match, then matching always fails"
[]
(let [_ (trace-dag "No rows left, add fail-node")]
(fail-node)))
(defn- first-row-empty-case
"Case 2: If the first row is empty then matching always succeeds
and yields the first action."
[rows ocr]
(let [^PatternRow f (first rows)
a (action f)
bs (bindings f)
_ (trace-dag "Empty row, add leaf-node."
"Could not find match for: " ocr
"Action:" a
"Bindings:" bs)]
;; FIXME: wtf f, the first row is an infinite list of nil - David
(leaf-node a bs)))
(defn- first-row-wildcards-case
"Case 2: If the first row is constituted by wildcards then matching
matching always succeeds and yields the first action."
[rows ocrs]
(letfn [(row-bindings
;; Returns bindings usable by leaf-node
[f ocrs]
(let [ps (.ps ^PatternRow f)
wc-syms (map #(sym %) ps)
wc-bindings (map vector wc-syms
(map leaf-bind-expr ocrs))]
(concat (bindings f)
wc-bindings)))]
(let [f (first rows)
a (action f)
bs (row-bindings f ocrs)
_ (trace-dag (str "First row all wildcards, add leaf-node." a bs))]
(leaf-node a bs))))
(declare pseudo-pattern? wildcard-pattern vector-pattern? pattern-matrix)
(defn- first-column-chosen-case
"Case 3a: The first column is chosen. Compute and return a switch/bind node
with a default matrix case"
[this col ocrs]
(letfn [(pseudo-patterns [matrix i]
(->> (column matrix i)
(filter pseudo-pattern?)))
(matrix-splitter [rows]
(let [f (first rows)
[x y] (split-with #(if (comparable? f)
(comparable? %)
(pattern-equals f %)) (rest rows))]
[(cons f x) y]))
(default-matrix [matrix]
(let [rs (rows matrix)
m (pattern-matrix
(into []
(drop (count (first (matrix-splitter (map first rs)))) rs))
(occurrences matrix))]
(if-not (empty-matrix? m)
(do
(trace-dag (str "Add specialized matrix on row of "
"wildcards as default matrix for next node"))
(compile m))
(do
(trace-dag (str "Add fail-node as default matrix for next "
"node (specialized matrix empty)"))
(fail-node)))))
;; if the user interleaves patterns we want to make them adjacent
;; up until the point that the first wildcard pattern appears in a
;; column. everything including and after a wildcard pattern is always
;; the default matrix
(group-rows [rows]
(let [[s-m-1 s-m-2] (map count (matrix-splitter (map first rows)))
[l r] [(take s-m-1 rows) (drop s-m-1 rows)]]
(letfn [(group [[r & rs :as rows]]
(if (seq rows)
(let [[fd rd] ((juxt filter remove)
#(pattern-equals (first r) (first %))
rs)]
(concat (cons r fd) (group rd)))))]
(into [] (concat (group l) r)))))
;; analyze vector patterns, if a vector-pattern containing a rest pattern
;; occurs, drop all previous vector patterns that it subsumes. note this
;; is a bit hard coding that should be removed when get a better sense
;; how to abstract a protocol for this.
(group-vector-patterns [ps]
(-> (reduce (fn [ps p]
(if (and (vector-pattern? p)
(contains-rest-pattern? p))
(conj (drop-while #(pattern-equals p %) ps) p)
(conj ps p)))
() ps)
reverse))
(collapse [ps]
(reduce (fn [a b]
(if (pattern-equals (first (rseq a)) b)
a
(conj a b)))
[] ps))
;; Returns a vector of relevant constructors in column i of matrix
(column-constructors [matrix i]
(let [cs (group-vector-patterns (column matrix i))]
(collapse (first (matrix-splitter cs)))))
;; Compile a decision trees for each constructor cs and returns a clause list
;; usable by a switch node
(switch-clauses [matrix cs]
(into []
(map (fn [c rows]
(let [s (-> matrix
(specialize c rows (occurrences matrix))
compile)]
[c s]))
cs (loop [[c :as cs] (seq cs) grouped [] rows (rows matrix)]
(if (nil? cs)
grouped
(let [[l r] (split-with #(pattern-equals c (first %)) rows)]
(recur (next cs) (conj grouped l) r)))))))
(switch-or-bind-node [col ocrs clauses default]
(letfn [(expression? [ocr]
(contains? (meta ocr) :ocr-expr))
(bind-variables [ocrs]
(mapcat (fn [ocr]
(let [bind-expr (get (meta ocr) :ocr-expr ::not-found)]
(if (not= bind-expr ::not-found)
[ocr bind-expr]
[ocr ocr])))
ocrs))]
(if (some expression? ocrs)
(let [b (bind-variables ocrs)
o (ocrs col)
n (switch-node o clauses default)
_ (trace-dag "Add bind-node on occurrence " o ", bindings" b)]
(bind-node b n))
(let [o (ocrs col)
_ (trace-dag "Add switch-node on occurrence " o)]
(switch-node o clauses default)))))]
(let [exp-matrix (reduce (fn [matrix p]
(specialize matrix p (rows matrix) (occurrences matrix)))
this (pseudo-patterns this col))
new-matrix (pattern-matrix (group-rows (rows exp-matrix)) (occurrences exp-matrix))
constrs (column-constructors new-matrix col)
clauses (switch-clauses new-matrix constrs)
default (default-matrix new-matrix)
_ (trace-dag "Column" col ":" constrs)]
(switch-or-bind-node col ocrs clauses default))))
(defn- other-column-chosen-case
"Case 3b: A column other than the first is chosen. Swap column col with the first column
and compile the result"
[this col]
(let [_ (trace-dag "Swap column " col)]
(compile (swap this col))))
;; # Pattern Matrix definition
(declare default-specialize-matrix)
(deftype PatternMatrix [rows ocrs _meta]
clojure.lang.IObj
(meta [_] _meta)
(withMeta [_ new-meta]
(PatternMatrix. rows ocrs new-meta))
IPatternMatrix
(width [_] (if (not (empty? rows))
(count (rows 0))
0))
(height [_] (count rows))
(dim [this] [(width this) (height this)])
(specialize [this p rows* ocrs*]
(if (satisfies? ISpecializeMatrix p)
(specialize-matrix p rows* ocrs*)
(default-specialize-matrix p rows* ocrs*)))
(column [_ i] (vec (map #(nth % i) rows)))
(compile [this]
(letfn [(choose-column
;; Return a column number of a column which contains at least
;; one non-wildcard constructor
[this]
(let [col (necessary-column this)
_ (trace-dag "Pick column" col "as necessary column.")]
col))
(first-column? [i]
(zero? i))
(empty-row? [row]
(let [ps (patterns row)]
(and (not (nil? ps))
(empty? ps))))]
(cond
(empty? rows) (empty-rows-case)
(empty-row? (first rows)) (first-row-empty-case rows (first ocrs))
(all-wildcards? (first rows)) (first-row-wildcards-case rows ocrs)
:else (let [col (choose-column this)]
(if (first-column? col)
(first-column-chosen-case this col ocrs)
(other-column-chosen-case this col))))))
(pattern-at [_ i j] ((rows j) i))
(row [_ j] (nth rows j))
(necessary-column [this]
(letfn [(score-column [i col]
[i (reduce (fn [score useful]
(if useful
(clojure.core/inc score)
score))
0 col)])]
(first
(->> (apply map vector (useful-matrix this))
(map-indexed score-column)
(reduce (fn [[col score :as curr]
[ocol oscore :as cand]]
(if (> oscore score) cand curr))
[0 0])))))
(useful-matrix [this]
(vec (->> (for [j (range (height this))
i (range (width this))]
(useful-p? this i j))
(partition (width this))
(map vec))))
(select [this]
(swap this (necessary-column this)))
(rows [_] rows)
(insert-row [_ i row]
(PatternMatrix. (into (conj (subvec rows 0 i) row) (subvec rows i))
ocrs
_meta))
(insert-rows [_ i rows]
(PatternMatrix. (into (into (subvec rows 0 i) rows) (subvec rows i))
ocrs
_meta))
(occurrences [_] ocrs)
(action-for-row [_ j]
(action (rows j)))
IVecMod
(drop-nth [_ i]
(PatternMatrix. (vec (map #(drop-nth % i) rows)) ocrs _meta))
;; Swap column number idx with the first column
(swap [_ idx]
(PatternMatrix. (vec (map #(swap % idx) rows))
(swap ocrs idx)
_meta)))
(defn ^PatternMatrix pattern-matrix [rows ocrs]
{:pre [(vector rows)
(vector ocrs)]}
(PatternMatrix. rows ocrs nil))
(defn empty-matrix? [pm]
(= (dim pm) [0 0]))
(defn useful-p? [pm i j]
(let [p (pattern-at pm i j)]
(cond
(constructor? p) (every? #(not (wildcard-pattern? %))
(take j (column pm i)))
;;(wildcard-pattern? p) (not (useful? (drop-nth pm i) j))
;;IMPORTANT NOTE: this calculation is very very slow,
;;we should look at this more closely - David
:else false)))
(defn useful? [pm j]
(some #(useful-p? pm % j)
(range (count (row pm j)))))
;; =============================================================================
;; ## Default Matrix Specialization
;; NOTE: not sure why we need pattern-equals here for this to work - David
(defn default-specialize-matrix [p rows ocrs]
(let [focr (first ocrs)
nrows (->> rows
(filter #(pattern-equals p (first %)))
(map #(drop-nth-bind % 0 focr))
vec)
nocrs (drop-nth ocrs 0)
_ (trace-dag "Perform default matrix specialization on ocr" focr
", new num ocrs: "
(count ocrs) "->" (count nocrs))]
(pattern-matrix nrows nocrs)))
;; =============================================================================
;; # Patterns
;;
;; -----------------------------------------------------------------------------
;; ## Wildcard Pattern
;;
;; A wildcard pattern accepts any value.
;;
;; In practice, the DAG compilation eliminates any wildcard patterns.
(defprotocol IWildcardPattern
(sym [this]))
(deftype WildcardPattern [sym _meta]
IWildcardPattern
(sym [_] sym)
clojure.lang.IObj
(meta [_] _meta)
(withMeta [_ new-meta]
(WildcardPattern. sym new-meta))
Object
(toString [_]
(str sym)))
(defn ^WildcardPattern wildcard-pattern
([] (WildcardPattern. '_ nil))
([sym]
{:pre [(symbol? sym)]}
(if (= sym '_)
(WildcardPattern. (gensym) nil)
(WildcardPattern. sym nil))))
(defn wildcard-pattern? [x]
(instance? WildcardPattern x))
;; Local bindings in pattern matching are emulated by using named wildcards.
;; See clojure.lang.Symbol dispatch for `emit-pattern`
(defn named-wildcard-pattern? [x]
(when (instance? WildcardPattern x)
(not= (.sym ^WildcardPattern x) '_)))
(defmethod print-method WildcardPattern [^WildcardPattern p ^Writer writer]
(.write writer (str "<WildcardPattern: " (.sym p) ">")))
;; -----------------------------------------------------------------------------
;; ## Literal Pattern
;;
;; A literal pattern is not further split into further patterns in the DAG
;; compilation phase.
;;
;; It "literally" matches a given occurrence.
(deftype LiteralPattern [l _meta]
clojure.lang.IObj
(meta [_] _meta)
(withMeta [_ new-meta]
(LiteralPattern. l new-meta))
IPatternCompile
(to-source* [this ocr]
(cond
(= l ()) `(empty? ~ocr)
(and (symbol? l) (not (-> l meta :local))) `(= ~ocr '~l)
:else `(= ~ocr ~l)))
Object
(toString [_]
(if (nil? l)
"nil"
(pr-str l))))
(defn ^LiteralPattern literal-pattern [l]
(LiteralPattern. l (meta l)))
(defn literal-pattern? [x]
(instance? LiteralPattern x))
(defmethod print-method LiteralPattern [^LiteralPattern p ^Writer writer]
(.write writer (str "<LiteralPattern: " p ">")))
;; -----------------------------------------------------------------------------
;; ## Seq Pattern
;;
;; A Seq Pattern is intended for matching `seq`s.
;;
;; They are split into multiple patterns, testing each element of the seq in order.
;;
(declare seq-pattern? rest-pattern? seq-pattern)
(deftype SeqPattern [s _meta]
clojure.lang.IObj
(meta [_] _meta)
(withMeta [_ new-meta]
(SeqPattern. s new-meta))
IPatternCompile
(to-source* [this ocr]
`(or (seq? ~ocr) (sequential? ~ocr)))
Object
(toString [_]
(str s))
ISpecializeMatrix
(specialize-matrix [this rows ocrs]
(let [focr (first ocrs)
nrows (->> rows
(map (fn [row]
(let [p (first row)
[h t] (if (seq-pattern? p)
(let [^SeqPattern p p
[h & t] (.s p)
t (cond
(empty? t) (literal-pattern ())
(rest-pattern? (first t)) (pattern (first t))
:else (seq-pattern t))]
[h t])
[(wildcard-pattern) (wildcard-pattern)])]
(reduce prepend (drop-nth-bind row 0 focr)
[t h]))))
vec)
nocrs (let [seq-ocr focr
seq-sym (or (-> seq-ocr meta :seq-sym) seq-ocr)
sym-meta {:occurrence-type :seq
:seq-sym seq-ocr}
hsym (gensym (str (name seq-sym) "_head__"))
hsym (with-meta hsym
(assoc sym-meta :bind-expr `(first ~seq-ocr)))
tsym (gensym (str (name seq-sym) "_tail__"))
tsym (with-meta tsym
(assoc sym-meta :bind-expr `(rest ~seq-ocr)))]
(into [hsym tsym] (drop-nth ocrs 0)))
_ (trace-dag "SeqPattern specialization on ocr " focr
", new num ocrs"
(count ocrs) "->" (count nocrs))]
(pattern-matrix nrows nocrs))))
(defn ^SeqPattern seq-pattern [s]
{:pre [(sequential? s)
(not (empty? s))]}
(SeqPattern. s nil))
(defn seq-pattern? [x]
(instance? SeqPattern x))
(defmethod print-method SeqPattern [^SeqPattern p ^Writer writer]
(.write writer (str "<SeqPattern: " p ">")))
;; -----------------------------------------------------------------------------
;; ### Rest Pattern
;;
;; A rest pattern represents the case of matching [2 3] in [1 & [2 3]]
;;
;; It is an implementation detail of other patterns, like SeqPattern.
(deftype RestPattern [p _meta]
IPatternContainer
(pattern [_] p)
clojure.lang.IObj
(meta [_] _meta)
(withMeta [_ new-meta]
(RestPattern. p new-meta))
Object
(toString [_]
p))
(defn ^RestPattern rest-pattern [p]
(RestPattern. p nil))
(defn rest-pattern? [x]
(instance? RestPattern x))
(defmethod print-method RestPattern [^RestPattern p ^Writer writer]
(.write writer (str "<RestPattern: " (.p p) ">")))
;; -----------------------------------------------------------------------------
;; # Map Pattern
;;
;; Map patterns match maps, or any object that satisfies IMatchLookup.
(declare map-pattern? guard-pattern)
(deftype MapPattern [m _meta]
clojure.lang.IObj
(meta [_] _meta)
(withMeta [_ new-meta]
(MapPattern. m new-meta))
IPatternCompile
(to-source* [this ocr]
(if *clojurescript*
`(satisfies? cljs.core/ILookup ~ocr)
`(or (instance? clojure.lang.ILookup ~ocr) (satisfies? IMatchLookup ~ocr))))
Object
(toString [_]
(str m " :only " (or (:only _meta) [])))
ISpecializeMatrix
(specialize-matrix [this rows ocrs]
(let [focr (first ocrs)
only? (atom false)
all-keys (->> rows
(remove (comp wildcard-pattern? first))
(map (fn [row]
(let [^MapPattern p (first row)
only (-> p meta :only)]
(when (and (not @only?) (seq only))
(reset! only? true))
[(set (keys (.m p)))
(set only)])))
(reduce concat)
(reduce set/union #{}))
wcs (repeatedly wildcard-pattern)
wc-map (zipmap all-keys wcs)
nrows (->> rows
(map (fn [row]
(let [p (first row)
only (seq (-> p meta :only))
ocr-map (if (map-pattern? p)
(let [^MapPattern p p
m (.m p)
[not-found-map wc-map] (if only
[(zipmap all-keys
(repeat (literal-pattern ::not-found)))
(zipmap only wcs)]
[{} wc-map])]
(merge not-found-map wc-map m))
wc-map)
ps (map ocr-map all-keys)
ps (if @only?
(if only
(let [a (with-meta (gensym) {:tag 'java.util.Map})]
(cons (guard-pattern (wildcard-pattern)
(set [(if *clojurescript*
`(fn [~a] (= (set (keys ~a)) #{~@only}))
`(fn [~a] (= (.keySet ~a) #{~@only})))]))
ps))
(cons (wildcard-pattern) ps))
ps)]
(reduce prepend (drop-nth-bind row 0 focr)
(reverse ps)))))
vec)
nocrs (let [map-ocr focr
ocr-sym (fn ocr-sym [k]
(let [ocr (gensym (str (name map-ocr) "_" (name k) "__"))]
(with-meta ocr
{:occurrence-type :map
:key k
:map-sym map-ocr
:bind-expr (val-at-expr map-ocr k ::not-found)})))
mocrs (map ocr-sym all-keys)
mocrs (if @only?
(cons map-ocr mocrs)
mocrs)]
(into (into [] mocrs)
(drop-nth ocrs 0)))
_ (trace-dag "MapPattern specialization")]
(pattern-matrix nrows nocrs))))
(defn ^MapPattern map-pattern
([] (MapPattern. {} nil))
([m] {:pre [(map? m)]}
(MapPattern. m nil)))
(defn map-pattern? [x]
(instance? MapPattern x))
(defmethod print-method MapPattern [^MapPattern p ^Writer writer]
(.write writer (str "<MapPattern: " p ">")))
;; -----------------------------------------------------------------------------
(defprotocol IVectorPattern
(split [this n]))
(declare vector-pattern?)
(defn touched? [vp]
(-> vp meta :touched))
(defn touch [vp]
(let [meta (meta vp)]
(with-meta vp (assoc meta :touched true))))
(defn touch-all-first [rows]
(->> rows
(map (fn [[p & ps :as row]]
(if (not (touched? p))
(assoc row 0 (touch p))
row)))
(into [])))
(deftype VectorPattern [v t size offset rest? _meta]
clojure.lang.IObj
(meta [_] _meta)
(withMeta [_ new-meta]
(VectorPattern. v t size offset rest? new-meta))
IPatternCompile
(to-source* [this ocr]
(if (and (touched? this) (not rest?) size (check-size? t))
(test-with-size-inline t ocr size)
(test-inline t ocr)))
Object
(toString [_]
(str v " " t))
IContainsRestPattern
(contains-rest-pattern? [_] rest?)
IVectorPattern
(split [this n]
(let [lv (subvec v 0 n)
rv (subvec v n)
pl (VectorPattern. lv t n offset false _meta)
pr (if (rest-pattern? (first rv))
(let [^RestPattern p (first rv)] (.p p))
(let [rest? (some rest-pattern? rv)
rvc (count rv)
size (if rest? (dec rvc) rvc)]
(VectorPattern. rv t size n rest? _meta)))]
[pl pr]))
ISpecializeMatrix
(specialize-matrix [this rows ocrs]
(if (not (touched? (ffirst rows)))
(pattern-matrix (touch-all-first rows) ocrs)
(let [focr (first ocrs)
^VectorPattern fp (ffirst rows)
[rest? min-size] (->> rows
(reduce (fn [[rest? min-size] [p & ps]]
(if (vector-pattern? p)
[(or rest? (.rest? ^VectorPattern p))
(min min-size (.size ^VectorPattern p))]
[rest? min-size]))
[false (.size ^VectorPattern fp)]))
[nrows nocrs] (if rest?
[(->> rows
(map (fn [row]
(let [p (first row)
ps (cond
(vector-pattern? p) (split p min-size)
:else [(wildcard-pattern) (wildcard-pattern)])]
(reduce prepend (drop-nth-bind row 0 focr) (reverse ps)))))
vec)
(let [vec-ocr focr
t (.t this)
ocr-meta {:occurrence-type t
:vec-sym vec-ocr}
vl-ocr (gensym (str (name vec-ocr) "_left__"))
vl-ocr (with-meta vl-ocr
(assoc ocr-meta :bind-expr (subvec-inline t (with-tag t vec-ocr) 0 min-size )))
vr-ocr (gensym (str (name vec-ocr) "_right__"))
vr-ocr (with-meta vr-ocr
(assoc ocr-meta :bind-expr (subvec-inline t (with-tag t vec-ocr) min-size)))]
(into [vl-ocr vr-ocr] (drop-nth ocrs 0)))]
[(->> rows
(map (fn [row]
(let [p (first row)
ps (if (vector-pattern? p)
(reverse (.v ^VectorPattern p))
(repeatedly min-size wildcard-pattern))]
(reduce prepend (drop-nth-bind row 0 focr) ps))))
vec)
(let [vec-ocr focr
ocr-sym (fn [i]
(let [ocr (gensym (str (name vec-ocr) "_" i "__"))
t (.t this)]
(with-meta ocr
{:occurrence-type t
:vec-sym vec-ocr
:index i
:bind-expr (if-let [offset (.offset this)]
(nth-offset-inline t (with-tag t vec-ocr) i offset)
(nth-inline t (with-tag t vec-ocr) i))})))]
(into (into [] (map ocr-sym (range min-size)))
(drop-nth ocrs 0)))])
matrix (pattern-matrix nrows nocrs)]
matrix))))
(defn ^VectorPattern vector-pattern
([] (vector-pattern [] ::vector nil nil))
([v]
(vector-pattern v ::vector nil nil))
([v t]
(vector-pattern v t nil nil nil))
([v t offset]
(vector-pattern v t offset nil))
([v t offset rest?] {:pre [(vector? v)]}
(let [c (count v)
size (if rest? (dec c) c)]
(VectorPattern. v t size offset rest? nil))))
(defn vector-pattern? [x]
(instance? VectorPattern x))
(defmethod print-method VectorPattern [^VectorPattern p ^Writer writer]
(.write writer (str "<VectorPattern: " p ">")))
;; -----------------------------------------------------------------------------
;; Or Patterns
(deftype OrPattern [ps _meta]
clojure.lang.IObj
(meta [_] _meta)
(withMeta [_ new-meta]
(OrPattern. ps new-meta))
Object
(toString [this]
(str ps))
ISpecializeMatrix
(specialize-matrix [this rows ocrs]
(let [ps (.ps this)
nrows (->> rows
(map (fn [row]
(let [p (first row)]
;; NOTE: hmm why can't we remove this - David
(if (and (pattern-equals this p)
(not (wildcard-pattern? p)))
(map (fn [p]
(update-pattern row 0 p)) ps)
[row]))))
(apply concat)
vec)
_ (trace-dag "OrPattern specialization")]
(pattern-matrix nrows ocrs))))
(defn ^OrPattern or-pattern [p]
{:pre [(vector? p)]}
(OrPattern. p nil))
(defn or-pattern? [x]
(instance? OrPattern x))
(defmethod print-method OrPattern [^OrPattern p ^Writer writer]
(.write writer (str "<OrPattern: " (.ps p) ">")))
;; -----------------------------------------------------------------------------
;; Pseudo-patterns
(defmulti pseudo-pattern? type)
(defmethod pseudo-pattern? OrPattern
[x] true)
(defmethod pseudo-pattern? :default
[x] false)
;; -----------------------------------------------------------------------------
;; ## Guard Patterns
;;
;; Guard patterns are used to represent guards on patterns, for example
;; `(1 :guard even?)`
;;
(declare guard-pattern?)
(deftype GuardPattern [p gs _meta]
clojure.lang.IObj
(meta [_] _meta)
(withMeta [_ new-meta]
(GuardPattern. p gs new-meta))
IPatternCompile
(to-source* [this ocr]
`(and ~@(map (fn [expr ocr]
(list expr ocr))
gs (repeat ocr))))
Object
(toString [this]
(str p " :guard " gs))
ISpecializeMatrix
(specialize-matrix [this rows ocrs]
(let [nrows (->> rows
(map (fn [row]
(let [p (first row)]
(if (guard-pattern? p)
(let [^GuardPattern p p]
(update-pattern row 0 (.p p)))
row))))
vec)
_ (trace-dag "GuardPattern specialization")]
(pattern-matrix nrows ocrs))))
(defn ^GuardPattern guard-pattern [p gs]
{:pre [(set? gs)]}
(GuardPattern. p gs nil))
(defn guard-pattern? [x]
(instance? GuardPattern x))
(defmethod print-method GuardPattern [^GuardPattern p ^Writer writer]
(.write writer (str "<GuardPattern " (.p p) " :guard " (.gs p) ">")))
;; -----------------------------------------------------------------------------
;; ## Predicate Patterns
;;
;; Predicate patterns are used to represent simple guards on patterns,
;; for example
;; `(1 :when even?)`
;;
;; The predicates in predicate patterns should not overlap. That is,
;; no two predicates should return the same answer given the same
;; input. For example, in the unlikely case that there was a function
;; named `four?` and defined as `(defn four? [x] (= 4 x))`, then using
;; `x :when four?` and `y :when even?` in the same match expression
;; will yield an incorrect decision tree. In cases where overlapping
;; predicates are desired, use guard patterns.
;;
(def preds (atom {}))
(defmacro defpred
([name]
(swap! preds assoc name name))
([name f]
(swap! preds assoc name f)))
(declare predicate-pattern?)
(deftype PredicatePattern [p gs _meta]
clojure.lang.IObj
(meta [_] _meta)
(withMeta [_ new-meta]
(PredicatePattern. p gs new-meta))
IPatternCompile
(to-source* [this ocr]
`(and ~@(map (fn [expr ocr]
(list expr ocr))
gs (repeat ocr))))
Object
(toString [this]
(str p " :when " gs))
ISpecializeMatrix
(specialize-matrix [this rows ocrs]
(let [nrows (->> rows
(map (fn [row]
(let [p (first row)]
(if (predicate-pattern? p)
(let [^PredicatePattern p p]
(update-pattern row 0 (.p p)))
row))))
vec)
_ (trace-dag "PredicatePattern specialization")]
(pattern-matrix nrows ocrs))))
(defn ^PredicatePattern predicate-pattern [p gs]
{:pre [(set? gs)]}
(PredicatePattern. p gs nil))
(defn predicate-pattern? [x]
(instance? PredicatePattern x))
(defmethod print-method PredicatePattern [^PredicatePattern p ^Writer writer]
(.write writer (str "<PredicatePattern " (.p p) " :when " (.gs p) ">")))
;; -----------------------------------------------------------------------------
;; Pattern Comparisons
(defmethod pattern-compare [WildcardPattern WildcardPattern]
[a b]
1)
(defmethod comparable? WildcardPattern
[x]
false)
;; NOTE: if recur is present we want all objects to equal wildcards, this is
;; because we push the wildcard matches along as well in the matrix specialization
;; since we don't have backtracking in this case - David
(defmethod pattern-compare [Object WildcardPattern]
[a b] (if *recur-present* 0 1))
(defmethod safe-pattern-compare [Object WildcardPattern]
[a b] 1)
(prefer-method pattern-compare [Object WildcardPattern] [LiteralPattern Object])
(defmethod pattern-compare [LiteralPattern Object]
[a b] 1)
(defmethod pattern-compare [Object LiteralPattern]
[a b] 1)
(defmethod pattern-compare [LiteralPattern LiteralPattern]
[^LiteralPattern a ^LiteralPattern b]
(let [la (.l a)
lb (.l b)]
(cond
(= la lb) 0
:else 1)))
(defmethod comparable? LiteralPattern
[x]
(not (-> x meta :local)))
(defmethod pattern-compare [GuardPattern GuardPattern]
[^GuardPattern a ^GuardPattern b] (if (= (.gs a) (.gs b)) 0 1))
(defmethod comparable? GuardPattern
[x]
false)
(defmethod pattern-compare [GuardPattern WildcardPattern]
[^GuardPattern a ^WildcardPattern b]
(let [p (.p a)]
(if (wildcard-pattern? p)
(pattern-compare p b) 1)))
(defmethod pattern-compare [PredicatePattern PredicatePattern]
[^PredicatePattern a ^PredicatePattern b] (if (= (.gs a) (.gs b)) 0 1))
(defmethod pattern-compare [PredicatePattern WildcardPattern]
[^PredicatePattern a ^WildcardPattern b]
(let [p (.p a)]
(if (wildcard-pattern? p)
(pattern-compare p b) 1)))
(defmethod pattern-compare [OrPattern OrPattern]
[^OrPattern a ^OrPattern b]
(let [as (.ps a)
bs (.ps b)]
(if (and (= (count as) (count bs))
(every? identity (map pattern-equals as bs)))
0 1)))
(defmethod pattern-compare [VectorPattern VectorPattern]
[^VectorPattern a ^VectorPattern b]
(cond
(not (touched? b)) 0
(= (.size a) (.size b)) 0
(and (.rest? a) (<= (.size a) (.size b))) 0
(and (.rest? b) (<= (.size b) (.size a))) 0
:else 1))
;; =============================================================================
;; # Interface
(defmulti to-source
"Returns a Clojure form that, when executed, is truthy if the pattern matches
the occurrence. Dispatches on the `type` of the pattern. For instance, a literal pattern
might return `(= ~(:pattern pattern) ~ocr)`, using `=` to test for a match."
(fn [pattern ocr] (type pattern)))
(defmulti emit-pattern
"Returns the corresponding pattern for the given syntax. Dispatches
on the class of its argument. For example, `[(:or 1 2) 2]` is dispatched
as clojure.lang.IPersistentVector"
class)
;; ============================================================================
;; # emit-pattern Methods
(defn emit-patterns
([ps t] (emit-patterns ps t []))
([ps t v]
(if (empty? ps)
v
(let [p (first ps)]
(cond
(= p '&) (let [p (second ps)
rp (if (and (vector? p) (= t :seq))
(seq-pattern (emit-patterns p t))
(emit-pattern p))]
(recur (nnext ps) t (conj v (rest-pattern rp))))
:else (recur (next ps) t (conj v (emit-pattern (first ps)))))))))
(defmethod emit-pattern clojure.lang.IPersistentVector
[pat]
(let [ps (emit-patterns pat :vector)]
(vector-pattern ps *vector-type* 0 (some rest-pattern? ps))))
(defmethod emit-pattern clojure.lang.IPersistentMap
[pat]
(map-pattern
(->> pat
(map (fn [[k v]]
[k (emit-pattern v)]))
(remove nil?)
(into {}))))
(defmethod emit-pattern clojure.lang.Symbol
[pat]
(if (get *locals* pat)
(literal-pattern (with-meta pat (assoc (meta pat) :local true)))
(wildcard-pattern pat)))
(defmethod emit-pattern :default
[pat]
(literal-pattern pat))
(declare emit-pattern-for-syntax or-pattern as-pattern guard-pattern
predicate-pattern vector-pattern)
(defmethod emit-pattern clojure.lang.ISeq
[pat] (if (and (= (count pat) 2)
(= (first pat) 'quote)
(or (symbol? (second pat))
(keyword? (second pat))))
(literal-pattern (second pat))
(emit-pattern-for-syntax pat)))
(defmulti emit-pattern-for-syntax
"Handles patterns wrapped in the special list syntax. Dispatches
on the first or second keyword in the list. For example, the pattern
`(:or 1 ...) is dispatches as :or, and `(1 :as a)` is dispatched by :as."
(fn [[f s]]
(if (keyword? f)
[f (type s)]
[(type f) s])))
(defmethod emit-pattern-for-syntax [:or Object]
[pat] (or-pattern
(->> (rest pat)
(map emit-pattern)
(into []))))
(defmethod emit-pattern-for-syntax [Object :as]
[[p _ sym]] (with-meta (emit-pattern p) {:as sym}))
(defmethod emit-pattern-for-syntax [Object :when]
[[p _ gs]]
(let [gs (if (not (vector? gs)) [gs] gs)]
(assert (every? symbol? gs) (str "Invalid predicate expression " gs))
(assert (every? #(contains? @preds %) gs) (str "Unknown predicate in " gs))
(predicate-pattern (emit-pattern p) (set gs))))
(defmethod emit-pattern-for-syntax [Object :guard]
[[p _ gs]] (let [gs (if (not (vector? gs)) [gs] gs)]
(guard-pattern (emit-pattern p) (set gs))))
(defmethod emit-pattern-for-syntax [Object :seq]
[pat]
(let [p (first pat)]
(if (empty? p)
(literal-pattern ())
(seq-pattern (emit-patterns p :seq)))))
(defmethod emit-pattern-for-syntax [Object ::vector]
[[p t offset-key offset]] (let [ps (emit-patterns p :vector)]
(vector-pattern ps t offset (some rest-pattern? ps))))
(defmethod emit-pattern-for-syntax [Object :only]
[[p _ only]] (with-meta (emit-pattern p) {:only only}))
(defmethod emit-pattern-for-syntax :default
[[_ s :as l]]
(throw (AssertionError.
(str "Invalid list syntax " s " in " l ". "
"Valid syntax: "
(vec (remove #(= % :default)
(keys (.getMethodTable ^clojure.lang.MultiFn emit-pattern-for-syntax))))))))
(let [void (Object.)
void? #(identical? void %)
infix-keyword? #(#{:when :as :guard} %)]
;; void is a unique placeholder for nothing -- we can't use nil
;; because that's a legal symbol in a pattern row
(defn- regroup-keywords [pattern]
(cond (vector? pattern)
(first (reduce (fn [[result p q] r]
(cond
(void? p) [result q r]
(and (not (void? r)) (infix-keyword? q))
[(conj result (list (regroup-keywords p) q r)) void void]
:else [(conj result (regroup-keywords p)) q r]))
[[] void void]
(conj pattern void void)))
(seq? pattern) (cons (regroup-keywords (first pattern)) (rest pattern))
:else pattern)))
(defn- group-keywords
"Returns a pattern with pattern-keywords (:when and :as) properly grouped.
The original pattern may use the 'flattened' syntax. For example, a 'flattened'
pattern row like [a b :when even?] is grouped as [a (b :when even?)]."
[pattern]
(if (vector? pattern) (regroup-keywords pattern) pattern))
(defn emit-clause [[pat action]]
(let [p (into [] (map emit-pattern (group-keywords pat)))]
(pattern-row p action)))
(defn- wildcards-and-duplicates
"Returns a vector of two elements: the set of all wildcards and the
set of duplicate wildcards. The underbar _ is excluded from both."
[patterns]
(loop [remaining patterns seen #{} dups #{}]
(if-let [patterns (seq remaining)]
(let [pat (first patterns)
pats (rest patterns)]
(cond (or (= pat '_) (= pat '&)) (recur pats seen dups)
(symbol? pat) (if (contains? seen pat)
(recur pats seen (conj dups pat))
(recur pats (conj seen pat) dups))
(vector? pat) (recur (concat pats pat) seen dups)
(map? pat) (recur (concat pats (vals pat)) seen dups)
(seq? pat) (cond
(= (first pat) 'quote) (recur pats seen dups)
(= (first pat) :or) (let [wds (map wildcards-and-duplicates
(map list (take-nth 2 pat)))
mseen (apply set/union (map first wds))]
(recur pats (set/union seen mseen)
(apply set/union dups
(set/intersection seen mseen)
(map second wds))))
(= (second pat) :as) (recur (concat pats (take-nth 2 pat)) seen dups)
:else (recur (conj pats (first pat)) seen dups))
:else (recur pats seen dups)))
[seen dups])))
(defn- find-duplicate-wildcards [pattern]
(second (wildcards-and-duplicates pattern)))
;; This could be scattered around in other functions to be more efficient
;; Turn off *syntax-check* to disable
(defn- check-matrix-args [vars clauses]
(cond
(symbol? vars) (throw (AssertionError.
(str "Occurrences must be in a vector."
" Try changing " vars " to [" vars "]")))
(not (vector? vars)) (throw (AssertionError.
(str "Occurrences must be in a vector. "
vars " is not a vector"))))
(letfn [(check-pattern [pat nvars rownum]
(let [pat (group-keywords pat)]
(cond
(not (vector? pat)) (throw (AssertionError.
(str "Pattern row " rownum
": Pattern rows must be wrapped in []."
" Try changing " pat " to [" pat "]."
(when (list? pat)
(str " Note: pattern rows are not patterns."
" They cannot be wrapped in a :when guard, for example")))))
(not= (count pat) nvars)
(throw (AssertionError.
(str "Pattern row " rownum
": Pattern row has differing number of patterns. "
pat " has " (count pat) " pattern/s, expecting "
nvars " for occurrences " vars))))
(when-let [duplicates (seq (find-duplicate-wildcards pat))]
(throw (AssertionError.
(str "Pattern row " rownum
": Pattern row reuses wildcards in " pat
". The following wildcards are ambiguous: " (apply str (interpose ", " duplicates))
". There's no guarantee that the matched values will be same. Rename the occurrences uniquely."))))))]
(let [nvars (count vars)
cls (partition 2 clauses)]
(doseq [[[pat _] rownum] (map vector (butlast cls) (rest (range)))]
(cond
(= :else pat) (throw (AssertionError.
(str "Pattern row " rownum
": :else form only allowed on final pattern row")))
:else (check-pattern pat nvars rownum)))
(when-let [[pat _] (last cls)]
(when-not (= :else pat)
(check-pattern pat nvars (count cls))))))
(when (odd? (count clauses))
(throw (AssertionError. (str "Uneven number of Pattern Rows. The last form `"
(last clauses) "` seems out of place.")))))
;; TODO: more sophisticated analysis that actually checks that recur is
;; not being used as a local binding when it occurs - David
(defn analyze-actions [actions]
(letfn [(analyze-action [action]
(if (and (sequential? action)
(some '#{recur} (flatten action)))
{:recur-present true} {}))]
(map analyze-action actions)))
(defn emit-matrix [vars clauses]
(let [cs (partition 2 clauses)
cs (let [[p a] (last cs)]
(if (= :else p)
(do (trace-matrix "Convert :else clause to row of wildcards")
(conj (vec (butlast cs)) [(->> vars (map (fn [_] '_)) vec) a]))
(conj (vec cs) [(->> vars (map (fn [_] '_)) vec) nil])))
clause-sources (into [] (map emit-clause cs))
vars (vec (map (fn [var]
(if (not (symbol? var))
(let [nsym (gensym "ocr-")
_ (trace-dag "Bind ocr" var "to" nsym)]
(with-meta nsym {:ocr-expr var}))
var))
vars))]
(pattern-matrix clause-sources vars)))
(defn executable-form [node]
(n-to-clj node))
(defn clj-form [vars clauses]
(when @*syntax-check* (check-matrix-args vars clauses))
(let [actions (map second (partition 2 clauses))
recur-present (some :recur-present
(analyze-actions actions))]
(binding [*recur-present* recur-present]
(-> (emit-matrix vars clauses)
compile
executable-form))))
;; ============================================================================
;; # Match macros
(defmacro match
"Pattern match a row of occurrences. Take a vector of occurrences, vars.
Clause question-answer syntax is like `cond`. Questions must be
wrapped in a vector, with same arity as vars. Last question can be :else,
which expands to a row of wildcards.
Example:
(let [x 1
y 2]
(match [x y 3]
[1 2 3] :answer1
:else :default-answer))"
[vars & clauses]
(let [[vars clauses] (if (vector? vars)
[vars clauses]
[(vector vars)
(mapcat (fn [[c a]]
[(if (not= c :else) (vector c) c) a])
(partition 2 clauses))])]
(binding [*line* (-> &form meta :line)
*locals* (dissoc &env '_)
*warned* (atom false)]
`~(clj-form vars clauses))))
(defmacro matchv [type vars & clauses]
(binding [*vector-type* type
*line* (-> &form meta :line)
*locals* (dissoc &env '_)
*warned* (atom false)]
`~(clj-form vars clauses)))
(defmacro match-let [bindings & body]
(let [bindvars# (take-nth 2 bindings)]
`(let ~bindings
(match [~@bindvars#]
~@body))))
(comment
(defn foo [dirs cljs]
(match [dirs cljs]
[[:nothing] []] [:nothing]
[[:nothing] lst] [:just lst]
[[:just a] b] [:just (concat a b)]))
)
Jump to Line
Something went wrong with that request. Please try again.