Skip to content


Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Fetching contributors…

Cannot retrieve contributors at this time

1529 lines (1306 sloc) 51.767 kb
(ns clojure.core.match.core
(:refer-clojure :exclude [compile])
(:require [clojure.set :as set])
(:import [ 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 _occurances_
;; * 1, 2, 3 and 4 are _patterns_
;; * [1 2] and [3 4] are _pattern rows_
;; * :a0 and :a1 are _actions_
(match [x y]
[1 2] :a0
[3 4] :a1))
;; ============================================
;; # Debugging tools
;; These debugging aids are most useful in steps 2 and 3 of compilation.
(set! *warn-on-reflection* true)
;; 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} *line*)
(def ^{:dynamic true} *locals*)
(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 warn [msg]
(if (not @*warned*)
(binding [*out* *err*]
(println "WARNING:"
(str *ns* ", line " *line* ":")
(reset! *warned* true))))
(defn trace-matrix [& p]
(when @*trace*
(apply println "TRACE: MATRIX:" p)
(defn trace-dag [& p]
(when @*trace*
(apply println "TRACE: DAG:" p)
;; =============================================================================
;; # Protocols
(defprotocol ISpecializeMatrix
(specialize-matrix [this matrix]))
(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
(val-at* [this k not-found]))
;; =============================================================================
;; # Map Pattern Interop
(extend-type clojure.lang.ILookup
(val-at* [this k not-found]
(.valAt this k not-found)))
(defn val-at
([m k] (val-at* m k nil))
([m k not-found] (val-at* m k not-found)))
;; =============================================================================
;; # Vector Pattern Interop
(defmulti check-size? identity)
(defmulti tag (fn [t] t))
(defmulti test-inline (fn [t & r] t))
(defmulti test-with-size-inline (fn [t & r] t))
(defmulti count-inline (fn [t & r] t))
(defmulti nth-inline (fn [t & r] t))
(defmulti nth-offset-inline (fn [t & r] t))
(defmulti subvec-inline (fn ([t & r] t)))
(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)
(with-meta ocr (assoc (ocr meta) :tag the-tag))))
(defmethod test-inline ::vector
[t 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)))
;; =============================================================================
;; # 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
(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
(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))
;; =============================================================================
;; # 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)
(declare named-wildcard-pattern?)
(declare sym)
(deftype PatternRow [ps action bindings]
(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 (if (named-wildcard-pattern? p)
(conj bindings [(sym p) bind-expr])
(PatternRow. (drop-nth ps n) action
(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))
(nth [_ i]
(nth ps i))
(nth [_ i x]
(nth ps i x))
(first [_] (first ps))
(next [_]
(if-let [nps (next ps)]
(PatternRow. nps action bindings)
(PatternRow. [] action bindings)))
(more [_]
(if (empty? ps)
(let [nps (rest ps)]
(PatternRow. nps action bindings))))
(seq [this]
(seq ps))
(count [_]
(count ps))
(invoke [_ n]
(nth ps n))
(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]
(n-to-clj [this]
(if (not (empty? bindings))
(let [bindings (remove (fn [[sym _]] (= sym '_))
`(let [~@(apply concat bindings)]
(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 ~(:map-sym m) ~(:key m))))
(defmethod leaf-bind-expr :default
[ocr] ocr)
;; -----------------------------------------------------------------------------
;; ## Fail Node
(defrecord FailNode []
(n-to-clj [this]
(if *recur-present*
(if @*breadcrumbs*
`(throw (Exception. (str "No match found. "
"Followed " ~(count *match-breadcrumbs*) " branches."
" Breadcrumbs: " '~*match-breadcrumbs*)))
`(throw (Exception. (str "No match found."))))
`(throw clojure.core.match.core/backtrack))))
(defn ^FailNode fail-node []
;; -----------------------------------------------------------------------------
;; ## Bind Node
(defrecord BindNode [bindings node]
(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 (extends? IPatternCompile (class 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)])))
(defrecord SwitchNode [occurrence cases default]
(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)))
`(throw clojure.core.match.core/backtrack))))))]
(if *recur-present*
(if bind-expr
`~(doall (concat `(let [~occurrence ~bind-expr]) (list cond-expr)))
(if bind-expr
`(try ~(doall (concat `(let [~occurrence ~bind-expr]) (list cond-expr)))
(catch Exception e#
~(n-to-clj default)))
`(try ~cond-expr
(catch Exception e#
~(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])
(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?)
(declare useful-p?)
(declare 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")]
(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)
(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?)
(declare wildcard-pattern)
(declare crash-pattern?)
(declare vector-pattern?)
(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 [this i]
(->> (column this i)
(filter pseudo-pattern?)))
;; When the current set of constructors is not a signature, an additional
;; call is performed on a default matrix, handling constructors not in the set.
(let [m (specialize this (wildcard-pattern))]
(if-not (empty-matrix? m)
(do (trace-dag "Add specialized matrix on row of wildcards as default matrix for next node")
(compile m))
(trace-dag "Add fail-node as default matrix for next node (specialized matrix empty)")
;; 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)
;; Returns a sorted-set of constructors in column i of matrix this
[this i]
(let [ps (group-vector-patterns (column this i))]
(->> ps
(filter (comp not wildcard-pattern?))
(apply sorted-set-by (fn [a b] (pattern-compare a b))))))
;; Compile a decision trees for each constructor cs and returns a clause list
;; usable by a switch node
[this cs]
(into []
(map (fn [c]
(let [s (-> this
(specialize c)
[c s]))
(switch-or-bind-node [col ocrs clauses default]
(letfn [(expression?
;; Returns true if occurance ocr is an expression
(contains? (meta ocr) :ocr-expr))
;; Return bindings usable by bind-node
(mapcat (fn [ocr]
(let [bind-expr (get (meta ocr) :ocr-expr ::not-found)]
(if (not= bind-expr ::not-found)
[ocr bind-expr]
[ocr ocr])))
(if (some expression? ocrs)
(let [b (bind-variables ocrs)
o (ocrs col)
n (switch-node o clauses default)
_ (trace-dag "Add bind-node on occurance " o ", bindings" b)]
(bind-node b n))
(let [o (ocrs col)
_ (trace-dag "Add switch-node on occurance " o)]
(switch-node o clauses default)))))]
(let [this (reduce specialize this (pseudo-patterns this col))
constrs (column-constructors this col)
clauses (switch-clauses this constrs)
default (default-matrix this)
_ (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]
(meta [_] _meta)
(withMeta [_ new-meta]
(PatternMatrix. rows ocrs new-meta))
(width [_] (if (not (empty? rows))
(count (rows 0))
(height [_] (count rows))
(dim [this] [(width this) (height this)])
(specialize [this p]
(if (satisfies? ISpecializeMatrix p)
(specialize-matrix p this)
(default-specialize-matrix p this)))
(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
(let [col (necessary-column this)
_ (trace-dag "Pick column" col "as necessary column.")]
(first-column? [i]
(zero? i))
(empty-row? [row]
(let [ps (patterns row)]
(and (not (nil? ps))
(empty? ps))))]
(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]
(some #{::crash} col) [i -1]
:else [i (reduce (fn [score useful]
(if useful
(clojure.core/inc score)
0 col)]))]
(->> (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 -2]))))) ;; NOTE: -2 because -1 is for crash columns - David
(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))
(insert-rows [_ i rows]
(PatternMatrix. (into (into (subvec rows 0 i) rows) (subvec rows i))
(occurrences [_] ocrs)
(action-for-row [_ j]
(action (rows j)))
(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)
(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)]
(crash-pattern? p) ::crash
(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
(defn default-specialize-matrix [this matrix]
(let [rows (rows matrix)
ocrs (occurrences matrix)
focr (first ocrs)
nrows (->> rows
(filter #(pattern-equals this (first %)))
(map #(drop-nth-bind % 0 focr))
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]
(sym [_] sym)
(meta [_] _meta)
(withMeta [_ new-meta]
(WildcardPattern. sym new-meta))
(toString [_]
(str sym)))
(defn ^WildcardPattern wildcard-pattern
([] (WildcardPattern. '_ nil))
{:pre [(symbol? sym)]}
(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 occurance.
(deftype LiteralPattern [l _meta]
(meta [_] _meta)
(withMeta [_ new-meta]
(LiteralPattern. l new-meta))
(to-source* [this ocr]
(= l ()) `(empty? ~ocr)
(and (symbol? l) (not (-> l meta :local))) `(= ~ocr '~l)
:else `(= ~ocr ~l)))
(toString [_]
(if (nil? l)
(str l))))
(defn ^LiteralPattern literal-pattern [l]
(LiteralPattern. l nil))
(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?)
(declare rest-pattern?)
(declare seq-pattern)
(deftype SeqPattern [s _meta]
(meta [_] _meta)
(withMeta [_ new-meta]
(SeqPattern. s new-meta))
(to-source* [this ocr]
`(or (seq? ~ocr) (sequential? ~ocr)))
(toString [_]
(str s))
(specialize-matrix [this matrix]
(let [rows (rows matrix)
ocrs (occurrences matrix)
focr (first ocrs)
srows (filter #(pattern-equals this (first %)) rows)
nrows (->> srows
(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]))))
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]
(pattern [_] p)
(meta [_] _meta)
(withMeta [_ new-meta]
(RestPattern. p new-meta))
(toString [_]
(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?)
(declare map-crash-pattern)
(deftype MapPattern [m _meta]
(meta [_] _meta)
(withMeta [_ new-meta]
(MapPattern. m new-meta))
(to-source* [this ocr]
`(or (instance? clojure.lang.ILookup ~ocr) (satisfies? IMatchLookup ~ocr)))
(toString [_]
(str m " :only " (or (:only _meta) [])))
(specialize-matrix [this matrix]
(let [rows (rows matrix)
ocrs (occurrences matrix)
focr (first ocrs)
srows (filter #(pattern-equals this (first %)) rows)
all-keys (->> srows
(remove (comp wildcard-pattern? first))
(map (fn [row]
(let [^MapPattern p (first row)]
[(set (keys (.m p)))
(set (-> p meta :only))])))
(reduce concat)
(reduce set/union #{})
sort) ;; NOTE: this assumes keys are of a homogenous type, can't sort #{1 :a} - David
wcs (repeatedly wildcard-pattern)
wc-map (zipmap all-keys wcs)
nrows (->> srows
(map (fn [row]
(let [p (first row)
ocr-map (if (map-pattern? p)
(let [^MapPattern p p
m (.m p)
[crash-map wc-map] (if-let [only (-> p meta :only)]
[(zipmap all-keys
(repeat (map-crash-pattern only)))
(zipmap only wcs)]
[{} wc-map])]
(merge crash-map wc-map m))
(reduce prepend (drop-nth-bind row 0 focr)
(reverse (map second (sort ocr-map)))))))
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 ~map-ocr ~k)})))]
(into (into [] (map ocr-sym all-keys))
(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 ">")))
;; ### MapCrashPattern
;; MapCrashPatterns are an implementation detail of MapPatterns.
;; They ensure a map has only the keys [:key1 :key2] in
;; the pattern:
;; ({:key1 1, :key2 2} :only [:key1 :key2])
(deftype MapCrashPattern [only _meta]
(meta [_] _meta)
(withMeta [_ new-meta]
(MapCrashPattern. only new-meta))
(to-source* [this ocr]
(let [map-sym (-> ocr meta :map-sym)]
`(= (.keySet ~(with-meta map-sym {:tag 'java.util.Map})) #{~@only})))
(toString [_]
(specialize-matrix [this matrix]
(let [rows (rows matrix)
ocrs (occurrences matrix)
nrows (->> rows
(filter #(pattern-equals this (first %)))
(map #(drop-nth % 0))
_ (trace-dag "MapCrashPattern specialization")]
(if (empty? nrows)
(pattern-matrix [] [])
(let [row (first nrows)]
(pattern-matrix [(pattern-row [] (action row) (bindings row))] []))))))
(defn ^MapCrashPattern map-crash-pattern [only]
(MapCrashPattern. only nil))
(defmethod print-method MapCrashPattern [^MapCrashPattern p ^Writer writer]
(.write writer (str "<MapCrashPattern>")))
;; -----------------------------------------------------------------------------
(defprotocol IVectorPattern
(split [this n]))
(declare vector-pattern?)
(deftype VectorPattern [v t size offset rest? _meta]
(meta [_] _meta)
(withMeta [_ new-meta]
(VectorPattern. v t size offset rest? new-meta))
(to-source* [_ ocr]
(if (and (not rest?) size (check-size? t))
(test-with-size-inline t ocr size)
(test-inline t ocr)))
(toString [_]
(str v " " t))
(contains-rest-pattern? [_] rest?)
(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]))
(specialize-matrix [this matrix]
(let [rows (rows matrix)
ocrs (occurrences matrix)
focr (first ocrs)
srows (filter #(pattern-equals this (first %)) rows)
^VectorPattern fp (ffirst srows)
[rest? min-size] (->> srows
(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?
[(->> srows
(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)))))
(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)))]
[(->> srows
(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))))
(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)]
(defn ^VectorPattern vector-pattern
([] (vector-pattern [] ::vector nil nil))
(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]
(meta [_] _meta)
(withMeta [_ new-meta]
(OrPattern. ps new-meta))
(toString [this]
(str ps))
(specialize-matrix [this matrix]
(let [ps (.ps this)
nrows (->> (rows matrix)
(map (fn [row]
(let [p (first row)]
(if (and (pattern-equals this p)
(not (wildcard-pattern? p)))
(map (fn [p]
(update-pattern row 0 p)) ps)
(apply concat)
_ (trace-dag "OrPattern specialization")]
(pattern-matrix nrows (occurrences matrix)))))
(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 :when even?)`
(declare guard-pattern?)
(deftype GuardPattern [p gs _meta]
(meta [_] _meta)
(withMeta [_ new-meta]
(GuardPattern. p gs new-meta))
(to-source* [this ocr]
`(and ~@(map (fn [expr ocr]
(list expr ocr))
gs (repeat ocr))))
(toString [this]
(str p " :when " gs))
(specialize-matrix [this matrix]
(let [nrows (->> (rows matrix)
(filter #(pattern-equals this (first %)))
(map (fn [row]
(let [p (first row)]
(if (guard-pattern? p)
(let [^GuardPattern p p]
(update-pattern row 0 (.p p)))
_ (trace-dag "GuardPattern specialization")]
(pattern-matrix nrows (occurrences matrix)))))
(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) " :when " (.gs p) ">")))
;; -----------------------------------------------------------------------------
;; Crash Patterns
(defmulti crash-pattern? type)
(defmethod crash-pattern? MapCrashPattern
[x] true)
(defmethod crash-pattern? :default
[x] false)
(defmethod pattern-compare [WildcardPattern WildcardPattern]
[a b] 0)
(defmethod pattern-compare [Object WildcardPattern]
[a b] (if *recur-present* 0 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)]
(= la lb) 0
:else 1)))
(defmethod pattern-compare [GuardPattern GuardPattern]
[^GuardPattern a ^GuardPattern b] (if (= (.gs a) (.gs b)) 0 1))
(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 [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]
(if (or (= (.size a) (.size b))
(and (.rest? a) (<= (.size a) (.size b)))
(and (.rest? b) (<= (.size b) (.size a))))
0 1))
;; =============================================================================
;; # Interface
(defmulti to-source
"Returns a Clojure form that, when executed, is truthy if the pattern matches
the occurance. 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, `[(1 | 2) 2]` is dispatched
as clojure.lang.IPersistentVector"
;; ============================================================================
;; # emit-pattern Methods
(defn emit-patterns
([ps t] (emit-patterns ps t []))
([ps t v]
(if (empty? ps)
(let [p (first ps)]
(= 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
(let [ps (emit-patterns pat :vector)]
(vector-pattern ps *vector-type* 0 (some rest-pattern? ps))))
(defmethod emit-pattern clojure.lang.IPersistentMap
(->> pat
(map (fn [[k v]]
[k (emit-pattern v)]))
(remove nil?)
(into {}))))
(defmethod emit-pattern clojure.lang.Symbol
(if (get *locals* pat)
(literal-pattern (with-meta pat (assoc (meta pat) :local true)))
(wildcard-pattern pat)))
(defmethod emit-pattern :default
(literal-pattern pat))
(declare emit-pattern-for-syntax)
(declare or-pattern)
(declare as-pattern)
(declare guard-pattern)
(declare vector-pattern)
(defmethod emit-pattern clojure.lang.ISeq
[pat] (if (and (= (count pat) 2)
(= (first pat) 'quote)
(symbol? (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 second item in the list. For example, the pattern `(1 :as a)`
is dispatched by :as."
(fn [syn] (second syn)))
(defmethod emit-pattern-for-syntax '|
[pat] (or-pattern
(->> pat
(remove '#{|})
(map emit-pattern)
(into []))))
(defmethod emit-pattern-for-syntax :as
[[p _ sym]] (with-meta (emit-pattern p) {:as sym}))
(defmethod emit-pattern-for-syntax :when
[[p _ gs]] (let [gs (if (not (vector? gs)) [gs] gs)]
(guard-pattern (emit-pattern p) (set gs))))
(defmethod emit-pattern-for-syntax :seq
(let [p (first pat)]
(if (empty? p)
(literal-pattern ())
(seq-pattern (emit-patterns p :seq)))))
(defmethod emit-pattern-for-syntax ::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 :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))))))))
(defn emit-clause [[pat action]]
(let [p (into [] (map emit-pattern pat))]
(pattern-row p action)))
;; This could be scattered around in other functions to be more efficient
;; Turn off *syntax-check* to disable
(defn- check-matrix-args [vars clauses]
(symbol? vars) (throw (AssertionError.
(str "Occurances must be in a vector."
" Try changing " vars " to [" vars "]")))
(not (vector? vars)) (throw (AssertionError.
(str "Occurances must be in a vector. "
vars " is not a vector"))))
(letfn [(check-pattern [pat nvars rownum]
(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 occurances " vars)))))]
(let [nvars (count vars)
cls (partition 2 clauses)]
(doseq [[[pat _] rownum] (map vector (butlast cls) (rest (range)))]
(= :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]))
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}))
(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)
;; ============================================================================
;; # Match macros
(defmacro match-1
"Pattern match a single value. Clause question-answer syntax is like
(let [x 1]
(match-1 x
1 :answer1
2 :answer2
:else :default-answer)))"
[vars & clauses]
(binding [*line* (-> &form meta :line)
*locals* (dissoc &env '_)
*warned* (atom false)]
(let [[vars clauses] [[vars] (mapcat (fn [[row action]]
(if (not= row :else)
[[row] action]
[row action]))
(partition 2 clauses))]]
`~(clj-form vars clauses))))
(defmacro match
"Pattern match a row of occurances. Take a vector of occurances, 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.
(let [x 1
y 2]
(match [x y 3]
[1 2 3] :answer1
:else :default-answer))"
[vars & 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)))
Jump to Line
Something went wrong with that request. Please try again.