├── .gitignore ├── README.md ├── project.clj ├── src ├── strucjure.clj └── strucjure │ ├── pattern.clj │ ├── sugar.clj │ ├── util.clj │ ├── view.clj │ └── view │ └── Failure.java └── test └── strucjure └── test.clj /.gitignore: -------------------------------------------------------------------------------- 1 | build/ 2 | classes/ 3 | lib/ 4 | target/ 5 | pom.xml 6 | .lein-failures 7 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | ["At some point as a programmer you might have the insight/fear that all programming is just doing stuff to other stuff."](http://highscalability.com/blog/2013/2/14/when-all-the-programs-a-graph-prismatics-plumbing-library.html) 2 | 3 | In idiomatic clojure data is not hidden behind classes and methods, but instead left lying around in a homogenous heap of stuff. Assumptions about the shape of stuff are implicitly encoded in the functions used to operate on it. When your stuff is the wrong shape things blow up far down the line in an unhelpful fashion. 4 | 5 | ``` clojure 6 | (defn f [{:keys [x y] :as z}] 7 | [x y z]) 8 | 9 | (f {:x 1 :y 2}) 10 | ;; [1 2 {:x 1 :y 2}] 11 | 12 | (f nil) 13 | ;; [nil nil nil] 14 | 15 | (f (list 1 2 3 4)) 16 | ;; [nil nil {1 2 3 4}] 17 | ``` 18 | 19 | Strucjure is a library for describing stuff in an executable manner. It gives you pattern matching (with first-class patterns), validators, parsers, walks and lenses (and eventually generators). The shape of your data is immediately apparent from your code and errors are clearly reported. 20 | 21 | ``` clojure 22 | (require '[strucjure.sugar :as s :refer [_]]) 23 | 24 | (defn g [input] 25 | (s/match input 26 | ^z (s/keys x y) [x y z])) 27 | 28 | (g {:x 1 :y 2}) 29 | ;; [1 2 {:x 1 :y 2}] 30 | 31 | (g nil) 32 | ;; strucjure.view.Failure: 33 | ;; Failed test (clojure.core/map? input6214) in pattern {:x #strucjure.pattern.Name{:name x, :pattern #strucjure.pattern.Any{}}, :y #strucjure.pattern.Name{:name y, :pattern #strucjure.pattern.Any{}}} on input nil 34 | 35 | (g (list 1 2 3 4)) 36 | ;; strucjure.view.Failure: 37 | ;; Failed test (clojure.core/map? input6214) in pattern {:x #strucjure.pattern.Name{:name x, :pattern #strucjure.pattern.Any{}}, :y #strucjure.pattern.Name{:name y, :pattern #strucjure.pattern.Any{}}} on input (1 2 3 4) 38 | ``` 39 | 40 | And the whole library is well under 500 loc. 41 | 42 | ## Concision 43 | 44 | Pattern matching tends to be far more concise than imperative style chains of boolean tests which we still use in clojure every day. 45 | 46 | Compare the imperative approach... 47 | 48 | ``` java 49 | private void adjustAfterInsertion(Node n) { 50 | // Step 1: color the node red 51 | setColor(n, Color.red); 52 | 53 | // Step 2: Correct double red problems, if they exist 54 | if (n != null && n != root && isRed(parentOf(n))) { 55 | 56 | // Step 2a (simplest): Recolor, and move up to see if more work 57 | // needed 58 | if (isRed(siblingOf(parentOf(n)))) { 59 | setColor(parentOf(n), Color.black); 60 | setColor(siblingOf(parentOf(n)), Color.black); 61 | setColor(grandparentOf(n), Color.red); 62 | adjustAfterInsertion(grandparentOf(n)); 63 | } 64 | 65 | // Step 2b: Restructure for a parent who is the left child of the 66 | // grandparent. This will require a single right rotation if n is 67 | // also 68 | // a left child, or a left-right rotation otherwise. 69 | else if (parentOf(n) == leftOf(grandparentOf(n))) { 70 | if (n == rightOf(parentOf(n))) { 71 | rotateLeft(n = parentOf(n)); 72 | } 73 | setColor(parentOf(n), Color.black); 74 | setColor(grandparentOf(n), Color.red); 75 | rotateRight(grandparentOf(n)); 76 | } 77 | 78 | // Step 2c: Restructure for a parent who is the right child of the 79 | // grandparent. This will require a single left rotation if n is 80 | // also 81 | // a right child, or a right-left rotation otherwise. 82 | else if (parentOf(n) == rightOf(grandparentOf(n))) { 83 | if (n == leftOf(parentOf(n))) { 84 | rotateRight(n = parentOf(n)); 85 | } 86 | setColor(parentOf(n), Color.black); 87 | setColor(grandparentOf(n), Color.red); 88 | rotateLeft(grandparentOf(n)); 89 | } 90 | } 91 | 92 | // Step 3: Color the root black 93 | setColor((Node) root, Color.black); 94 | } 95 | ``` 96 | 97 | ...to the declarative approach. 98 | 99 | ``` clojure 100 | (defrecord Red [value left right]) 101 | (defrecord Black [value left right]) 102 | 103 | (defn balance [tree] 104 | (s/match tree 105 | (s/or 106 | (Black. ^z _ (Red. ^y _ (Red. ^x _ ^a _ ^b _) ^c _) ^d _) 107 | (Black. ^z _ (Red. ^x _ ^a _ (Red. ^y _ ^b _ ^c _)) ^d _) 108 | (Black. ^x _ ^a _ (Red. ^z _ (Red. ^y _ ^b _ ^c _) ^d _)) 109 | (Black. ^x _ ^a _ (Red. ^y _ ^b _ (Red. ^z _ ^c _ ^d _)))) 110 | (Red. y (Black. x a b) (Black. z c d)) 111 | 112 | ^other _ 113 | other)) 114 | ``` 115 | 116 | ## First-class patterns 117 | 118 | Patterns in strucjure are first-class. The pattern part of the match statement is not a special langauge but just clojure code that is evaluated at compile-time and returns an instance of the `Pattern` and `View` protocols. This means you can easily extend the pattern language. 119 | 120 | ``` clojure 121 | (match {:a 1 :b 2} 122 | {:a ^a _ :b ^b _} [a b]) 123 | 124 | ;; too verbose, let's fix it 125 | 126 | (defn my-keys* [symbols] 127 | (for-map [symbol symbols] 128 | (keyword (str symbol)) 129 | (s/name symbol _))) 130 | 131 | (defmacro my-keys [& symbols] 132 | `(my-keys* '~symbols))) 133 | 134 | (s/match {:a 1 :b 2} 135 | (my-keys a b) [a b]) 136 | ``` 137 | 138 | Even the recursive patterns used in parsing are first-class data structures which can be modified and composed. 139 | 140 | ``` clojure 141 | (def expr 142 | (s/letp [num (s/or succ zero) 143 | succ (s/case ['succ num] (inc num)) 144 | zero (s/case 'zero 0) 145 | expr (s/or num add) 146 | add (s/case ['add ^a expr ^b expr] (+ a b))] 147 | expr)) 148 | 149 | (match '(add (succ zero) (succ zero)) 150 | ^result expr result) 151 | ;; 2 152 | 153 | (def expr-with-sub 154 | (-> expr 155 | (update-in [:refers 'expr] #(s/or % (->Refer 'sub))) 156 | (assoc-in [:refers 'sub] (s/case ['sub ^a expr ^b expr] (- a b))))) 157 | 158 | (s/match '(sub (add (succ zero) (succ zero)) (succ zero)) 159 | ^result expr-with-sub result) 160 | ;; 1 161 | ``` 162 | 163 | ## Error reporting 164 | 165 | The errors produced by failing matches contain a list of every point at which the match backtracked (in reverse order). 166 | 167 | ``` clojure 168 | (s/match [1 2 3] 169 | [1 2] :nope 170 | [1 2 3 4] :nope 171 | [1 :x] :oh-noes) 172 | ;; strucjure.view.Failure: 173 | ;; Failed test (clojure.core/= literal__6312__auto__ input6214) in pattern :x on input 2 174 | ;; Failed test (clojure.core/not (clojure.core/nil? input6214)) in pattern 4 on input nil 175 | ;; Failed test (clojure.core/nil? input6214) in pattern nil on input (3) 176 | 177 | (s/match '(add (sub (succ zero) (succ zero)) (succ zero)) 178 | ^result expr result) 179 | ;; strucjure.view.Failure: 180 | ;; Failed test (clojure.core/= literal__6312__auto__ input6214) in pattern add on input sub 181 | ;; Failed test (clojure.core/= literal__6312__auto__ input6214) in pattern zero on input (sub (succ zero) (succ zero)) 182 | ;; Failed test (clojure.core/= literal__6312__auto__ input6214) in pattern succ on input sub 183 | ;; Failed test (clojure.core/= literal__6312__auto__ input6214) in pattern zero on input (add (sub (succ zero) (succ zero)) (succ zero)) 184 | ;; Failed test (clojure.core/= literal__6312__auto__ input6214) in pattern succ on input add 185 | ``` 186 | 187 | If that isn't enough to locate the failure you can also run the match with tracing enabled: 188 | 189 | ``` clojure 190 | (with-out-str 191 | (match-with trace-let '(add (add (succ zero) (succ zero)) (succ zero)) 192 | expr expr)) 193 | ;; => expr (add (add (succ zero) (succ zero)) (succ zero)) 194 | ;; => num (add (add (succ zero) (succ zero)) (succ zero)) 195 | ;; => succ (add (add (succ zero) (succ zero)) (succ zero)) 196 | ;; XX succ # 198 | ;; => zero (add (add (succ zero) (succ zero)) (succ zero)) 199 | ;; XX zero # 202 | ;; XX num # 205 | ;; => add (add (add (succ zero) (succ zero)) (succ zero)) 206 | ;; => expr (add (succ zero) (succ zero)) 207 | ;; => num (add (succ zero) (succ zero)) 208 | ;; => succ (add (succ zero) (succ zero)) 209 | ;; XX succ # 213 | ;; => zero (add (succ zero) (succ zero)) 214 | ;; XX zero # 219 | ;; XX num # 224 | ;; => add (add (succ zero) (succ zero)) 225 | ;; => expr (succ zero) 226 | ;; => num (succ zero) 227 | ;; => succ (succ zero) 228 | ;; => num zero 229 | ;; => succ zero 230 | ;; XX succ # 236 | ;; => zero zero 237 | ;; <= zero 0 238 | ;; <= num 0 239 | ;; <= succ 1 240 | ;; <= num 1 241 | ;; <= expr 1 242 | ;; => expr (succ zero) 243 | ;; => num (succ zero) 244 | ;; => succ (succ zero) 245 | ;; => num zero 246 | ;; => succ zero 247 | ;; XX succ # 254 | ;; => zero zero 255 | ;; <= zero 0 256 | ;; <= num 0 257 | ;; <= succ 1 258 | ;; <= num 1 259 | ;; <= expr 1 260 | ;; <= add 2 261 | ;; <= expr 2 262 | ;; => expr (succ zero) 263 | ;; => num (succ zero) 264 | ;; => succ (succ zero) 265 | ;; => num zero 266 | ;; => succ zero 267 | ;; XX succ # 275 | ;; => zero zero 276 | ;; <= zero 0 277 | ;; <= num 0 278 | ;; <= succ 1 279 | ;; <= num 1 280 | ;; <= expr 1 281 | ;; <= add 3 282 | ;; <= expr 3 283 | ``` 284 | 285 | ## Performance 286 | 287 | The aim for the 1.0 release is for every match to execute at least as fast as the equivalent idiomatic clojure code. 288 | 289 | ``` clojure 290 | (= {:a 1 :b 2} 291 | {:a 1 :b 2}) 292 | ;; 173 ns 293 | 294 | (let [{:keys [a b]} {:a 1 :b 2}] 295 | (and (= a 1) (= b 2))) 296 | ;; 464 ns (really?) 297 | 298 | (match {:a 1 :b 2} 299 | {:a 1 :b 2} :ok) 300 | ;; 159 ns 301 | ``` 302 | 303 | Binding variables in a match is currently expensive relative to normal clojure destructuring (due to using `proteus.Container$0` to fake mutable variables). 304 | 305 | ``` clojure 306 | (let [{:keys [a b]} {:a 1 :b 2}] 307 | [a b]) 308 | ;; 123 ns 309 | 310 | (s/match {:a 1 :b 2} 311 | (s/keys a b) [a b]) 312 | ;; 648 ns :( 313 | ``` 314 | 315 | Other performance disparities are less clear. 316 | 317 | ``` clojure 318 | (defn f [pairs] 319 | (if-let [[x y & more] pairs] 320 | (cons (clojure.core/+ x y) (f more)) 321 | nil)) 322 | 323 | (f (range 10)) 324 | ;; 3.5 us 325 | 326 | (defn g [pairs] 327 | (match pairs 328 | [^x _ ^y _ ^more (& _)] (cons (clojure.core/+ x y) (g more)) 329 | [] nil)) 330 | 331 | (g (range 10)) 332 | ;; 7.1 us 333 | 334 | (defn h [pairs] 335 | (match pairs 336 | (letp [p (case [^x _ ^y _ (& p)] (cons (clojure.core/+ x y) p) 337 | [] nil)] 338 | p))) 339 | 340 | (h (range 10)) 341 | ;; 9.7 µs 342 | ``` 343 | 344 | Nethertheless, there is no reason why pattern matching shouldn't eventually be faster, especially since they allow complex parsing with only a single pass over the input data. 345 | 346 | ## More 347 | 348 | See the [tests](https://github.com/jamii/strucjure/blob/master/test/strucjure/test.clj) for detailed examples of the various patterns available. 349 | 350 | ## License 351 | 352 | Distributed under the GNU Lesser General Public License. 353 | -------------------------------------------------------------------------------- /project.clj: -------------------------------------------------------------------------------- 1 | (defproject strucjure "0.4.0" 2 | :description "Pattern-matching, parsing and generic traversals via PEGs" 3 | :url "http://github.com/jamii/strucjure" 4 | :license {:name "Eclipse Public License - v 1.0" 5 | :url "http://www.eclipse.org/legal/epl-v10.html" 6 | :distribution :repo} 7 | :java-source-paths ["src"] 8 | :jvm-opts ^:replace ["-server"] 9 | :dependencies [[org.clojure/clojure "1.5.1"] 10 | [prismatic/plumbing "0.1.0"] 11 | [proteus "0.1.4"]]) 12 | -------------------------------------------------------------------------------- /src/strucjure.clj: -------------------------------------------------------------------------------- 1 | (ns strucjure) -------------------------------------------------------------------------------- /src/strucjure/pattern.clj: -------------------------------------------------------------------------------- 1 | (ns strucjure.pattern 2 | (:require [clojure.set :refer [union difference]] 3 | [plumbing.core :refer [for-map aconcat map-vals]] 4 | [strucjure.util :refer [extend-protocol-by-fn try-vary-meta try-with-meta]]) 5 | (:import [clojure.lang ISeq IPersistentVector IPersistentMap IRecord])) 6 | 7 | ;; TODO Records 8 | 9 | (defprotocol Pattern 10 | (subpatterns [this] "A list of subpatterns of this pattern (just children, not descendants)") 11 | (with-subpatterns [this subpatterns] "Replace the subpatterns of this pattern, preserving metadata (if the number of subpatterns is wrong the behaviour is unspecified)") 12 | (bound [this] "Which names are bound by this pattern (not by subpatterns))")) 13 | 14 | ;; patterns 15 | (defrecord Any []) 16 | (defrecord Is [f]) 17 | (defrecord Guard [pattern code]) 18 | (defrecord Name [name pattern]) 19 | (defrecord Repeated [min-count max-count pattern]) 20 | (defrecord WithMeta [pattern meta-pattern]) 21 | (defrecord Or [patterns]) 22 | (defrecord And [patterns]) 23 | 24 | ;; recursive patterns 25 | (defrecord Refer [name]) 26 | (defrecord Let [refers pattern]) 27 | 28 | ;; pseudo-patterns 29 | (defrecord Rest [pattern]) 30 | (defrecord Output [pattern code]) 31 | (defrecord Trace [name pattern]) 32 | 33 | (defn walk [pattern f] 34 | (with-subpatterns pattern (map f (subpatterns pattern)))) 35 | 36 | (extend-protocol-by-fn 37 | Pattern 38 | 39 | (fn subpatterns [this] 40 | [nil Object Any Is Refer] nil 41 | [ISeq IPersistentVector] this 42 | [IPersistentMap IRecord] (vals this) 43 | [Rest Guard Name Repeated Output Let Trace] [(:pattern this)] 44 | [WithMeta] [(:pattern this) (:meta-pattern this)] 45 | [Or And] (:patterns this)) 46 | 47 | (fn with-subpatterns [this subpatterns] 48 | [nil Object Any Is Refer] this 49 | [ISeq] (apply list subpatterns) 50 | [IPersistentVector] (vec subpatterns) 51 | [IPersistentMap IRecord] (reduce (fn [this [key value]] (assoc this key value)) this (map vector (keys this) subpatterns)) 52 | [Rest Guard Name Repeated Output Let Trace] (assoc this :pattern (first subpatterns)) 53 | [WithMeta] (assoc this :pattern (first subpatterns) :meta-pattern (second subpatterns)) 54 | [Or And] (assoc this :patterns subpatterns)) 55 | 56 | (fn bound [this] 57 | [nil Object ISeq IPersistentVector IPersistentMap IRecord Any Is Rest Guard Repeated WithMeta Or And Refer Let Output Trace] #{} 58 | [Name] #{(:name this)})) 59 | 60 | (defn with-bound [pattern] 61 | (let [subpatterns&bound-below (map with-bound (subpatterns pattern)) 62 | bound-here (apply union (bound pattern) (map second subpatterns&bound-below)) 63 | pattern (with-subpatterns pattern (map first subpatterns&bound-below)) 64 | pattern (try-vary-meta pattern assoc :bound-here bound-here)] 65 | [pattern bound-here])) 66 | -------------------------------------------------------------------------------- /src/strucjure/sugar.clj: -------------------------------------------------------------------------------- 1 | (ns strucjure.sugar 2 | (:refer-clojure :exclude [with-meta * + or and name case keys]) 3 | (:require [plumbing.core :refer [fnk for-map aconcat]] 4 | [strucjure.pattern :as pattern :refer [->Rest ->Any ->Is ->Guard ->Name ->Or ->And ->Repeated ->WithMeta ->Output ->Let ->Refer ->Trace]] 5 | [strucjure.view :as view]) 6 | (:import [strucjure.pattern Let])) 7 | 8 | (def _ (->Any)) 9 | (defmacro is [f] `(->Is '~f)) 10 | (defmacro guard [pattern code] `(->Guard ~pattern '~code)) 11 | (def name ->Name) 12 | (defn * [pattern] (->Repeated 0 Long/MAX_VALUE pattern)) 13 | (defn + [pattern] (->Repeated 1 Long/MAX_VALUE pattern)) 14 | (defn ? [pattern] (->Repeated 1 1 pattern)) 15 | (def with-meta ->WithMeta) 16 | (defn or [& patterns] (->Or (vec patterns))) 17 | (defn and [& patterns] (->And (vec patterns))) 18 | (def & ->Rest) 19 | (defn &* [pattern] (& (* pattern))) 20 | (defn &+ [pattern] (& (+ pattern))) 21 | (defn &? [pattern] (& (? pattern))) 22 | (defn &*& [pattern] (& (* (& pattern)))) 23 | (defn &+& [pattern] (& (+ (& pattern)))) 24 | (defn &?& [pattern] (& (? (& pattern)))) 25 | (defn *& [pattern] (* (& pattern))) 26 | (defn +& [pattern] (+ (& pattern))) 27 | (defn ?& [pattern] (? (& pattern))) 28 | 29 | (def not-nil (is #(not (nil? %)))) 30 | 31 | (defmacro output [pattern code] `(->Output ~pattern '~code)) 32 | 33 | (defn- with-names [form] 34 | (clojure.walk/prewalk 35 | (fn [form] 36 | (if-let [name (:tag (meta form))] 37 | `(->Name '~name ~(vary-meta form dissoc :tag)) 38 | form)) 39 | form)) 40 | 41 | (defmacro pattern [sugar] 42 | (with-names sugar)) 43 | 44 | (defmacro case [& patterns&outputs] 45 | (cond 46 | (= 1 (count patterns&outputs)) `(pattern ~(first patterns&outputs)) 47 | (even? (count patterns&outputs)) `(->Or [~@(for [[pattern output] (partition 2 patterns&outputs)] 48 | `(->Output (pattern ~pattern) '~output))]))) 49 | 50 | (defmacro letp [names&patterns & patterns&outputs] 51 | `(let [~@(aconcat 52 | (for [[name pattern] (partition 2 names&patterns)] 53 | [name `(->Name '~name (->Refer '~name))]))] 54 | (->Let ~(for-map [[name pattern] (partition 2 names&patterns)] `'~name `(pattern ~pattern)) 55 | (case ~@patterns&outputs)))) 56 | 57 | (defn keys* [& symbols] 58 | (for-map [symbol symbols] 59 | (keyword (str symbol)) 60 | (->Name symbol (->Any)))) 61 | 62 | (defmacro keys [& symbols] 63 | `(keys* ~@(for [symbol symbols] `'~symbol))) 64 | 65 | (defmacro match [input & patterns&outputs] 66 | (let [pattern (eval `(case ~@patterns&outputs))] 67 | `(let [~view/input ~input] ~(view/view-top pattern)))) 68 | 69 | (defn trace-let [pattern] 70 | (if (instance? Let pattern) 71 | (assoc (pattern/walk pattern trace-let) 72 | :refers (for-map [[name pattern] (:refers pattern)] name 73 | (->Trace (str name) (trace-let pattern)))) 74 | (pattern/walk pattern trace-let))) 75 | 76 | (defn trace-all [pattern] 77 | (->Trace (pr-str pattern) 78 | (if (instance? Let pattern) 79 | (assoc (pattern/walk pattern trace-all) 80 | :refers (for-map [[name pattern] (:refers pattern)] name (trace-all pattern))) 81 | (pattern/walk pattern trace-all)))) 82 | 83 | (defmacro match-with [tracer input & patterns&outputs] 84 | (let [pattern (eval `(~tracer (case ~@patterns&outputs)))] 85 | `(let [~view/input ~input 86 | ~view/depth (proteus.Containers$O. 0)] 87 | ~(view/view-top pattern)))) -------------------------------------------------------------------------------- /src/strucjure/util.clj: -------------------------------------------------------------------------------- 1 | (ns strucjure.util 2 | (:refer-clojure :exclude [assert]) 3 | (:require [clojure.set :refer [union]] 4 | [plumbing.core :refer [aconcat]])) 5 | 6 | (defmacro extend-protocol-by-fn [protocol & fns] 7 | (let [class->fns (apply merge-with union 8 | (for [[fn-symbol fn-name fn-args & classes&bodies] fns 9 | [classes body] (partition 2 classes&bodies) 10 | class classes] 11 | {class #{(list fn-name fn-args body)}}))] 12 | `(extend-protocol ~protocol 13 | ~@(aconcat (for [[class fns] class->fns] (cons class fns)))))) 14 | 15 | (defn try-vary-meta [obj & args] 16 | (if (instance? clojure.lang.IObj obj) 17 | (apply vary-meta obj args) 18 | obj)) 19 | 20 | (defn try-with-meta [obj meta] 21 | (if (instance? clojure.lang.IObj obj) 22 | (with-meta obj meta) 23 | obj)) 24 | -------------------------------------------------------------------------------- /src/strucjure/view.clj: -------------------------------------------------------------------------------- 1 | (ns strucjure.view 2 | (:require [clojure.walk :refer [prewalk postwalk-replace]] 3 | [plumbing.core :refer [aconcat for-map]] 4 | [strucjure.util :refer [extend-protocol-by-fn try-with-meta]] 5 | [strucjure.pattern :as pattern] 6 | [proteus :refer [let-mutable]]) 7 | (:import [clojure.lang ISeq IPersistentVector IPersistentMap IRecord] 8 | [strucjure.pattern Any Is Rest Guard Name Repeated WithMeta Or And Refer Let Output Trace] 9 | [strucjure.view Failure])) 10 | 11 | ;; TODO 12 | ;; parsing Rest Repeated seq->view 13 | ;; recursive Refer Let 14 | 15 | ;; INTERFACE 16 | 17 | (defprotocol View 18 | (view [this info])) 19 | 20 | (def input (gensym "input")) 21 | 22 | (defmacro let-input [value body] 23 | `(let [~input ~value] ~body)) 24 | 25 | ;; FAILURE 26 | 27 | (def last-failure 28 | (gensym "last-failure")) 29 | 30 | (defmacro on-fail [t f] 31 | `(try ~t 32 | (catch Failure exc# 33 | (.set ~last-failure exc#) 34 | ~f))) 35 | 36 | (defmacro trap-failure [body] 37 | `(try ~body 38 | (catch Exception exc# 39 | (if (instance? Failure exc#) 40 | (throw (Exception. (str exc#))) 41 | (throw exc#))))) 42 | 43 | (defmacro check [pred pattern] 44 | `(when-not ~pred 45 | (throw (Failure. ~(pr-str pred) ~(pr-str pattern) ~input (.x ~last-failure))))) 46 | 47 | ;; REMAINING 48 | 49 | ;; Invariants: 50 | ;; remaining is always nil at start of pattern 51 | ;; if remaining? is false then the pattern may not set remaining 52 | 53 | (def remaining 54 | (gensym "remaining")) 55 | 56 | (defmacro get-remaining [] 57 | `(.x ~remaining)) 58 | 59 | (defmacro set-remaining [value] 60 | `(.set ~remaining ~value)) 61 | 62 | (defmacro pass-remaining [remaining? value pattern] 63 | (cond 64 | remaining? `(set-remaining ~value) 65 | value `(check (nil? ~value) ~pattern))) 66 | 67 | (defmacro clear-remaining [remaining? body] 68 | (if remaining? 69 | `(do (set-remaining nil) 70 | ~body) 71 | body)) 72 | 73 | ;; WRAPPER 74 | 75 | (defn view-with-locals [pattern info] 76 | (let [[pattern bound] (pattern/with-bound pattern)] 77 | `(let [~@(interleave bound (repeat `(proteus.Containers$O. nil)))] 78 | ~(view pattern info)))) 79 | 80 | (defn view-top [pattern] 81 | `(let [~last-failure (proteus.Containers$O. nil) 82 | ~remaining (proteus.Containers$O. nil)] 83 | ~(view-with-locals pattern {:name->view {} :output? true :remaining? false}))) 84 | 85 | ;; UTILS 86 | 87 | (defn rest? [pattern] 88 | (or (instance? Rest pattern) 89 | (and (instance? Name pattern) 90 | (rest? (:pattern pattern))))) 91 | 92 | (defn seqable? [input] 93 | (or (nil? input) (instance? clojure.lang.Seqable input))) 94 | 95 | (defn view-first [pattern info] 96 | `(do (check (not (nil? ~input)) ~pattern) 97 | (let-input (first ~input) ~(view pattern (assoc info :remaining? false))))) 98 | 99 | (defn let-bound [bound code] 100 | `(let [~@(aconcat 101 | (for [name bound] 102 | [name `(.x ~name)]))] 103 | ~code)) 104 | 105 | (def depth 106 | (gensym "depth")) 107 | 108 | ;; STRUCTURAL PATTERNS 109 | 110 | (defn seq->view [pattern {:keys [output? remaining?] :as info}] 111 | (if-let [[first-pattern & next-pattern] pattern] 112 | (if (rest? first-pattern) 113 | `(~(if output? 'concat 'do) 114 | ~(view first-pattern info) 115 | (let-input (get-remaining) (clear-remaining true ~(seq->view next-pattern info)))) 116 | `(~(if output? 'cons 'do) 117 | ~(view-first first-pattern info) 118 | (let-input (next ~input) ~(seq->view next-pattern info)))) 119 | `(do (pass-remaining ~remaining? ~input ~pattern) nil))) 120 | 121 | (defn or->view [patterns {:keys [remaining?] :as info}] 122 | (assert (not (empty? patterns)) "OR patterns must not be empty") 123 | ;;(let [bindings (for [pattern patterns] (let [[_ bound] (pattern/with-bound pattern)] bound))] 124 | ;; (assert (every? #(= (first bindings) %) bindings) "All branches of an Or pattern must have the same bound variables")) 125 | (let [[first-pattern & next-pattern] patterns] 126 | (if next-pattern 127 | `(on-fail ~(view first-pattern info) 128 | (clear-remaining remaining? ~(or->view next-pattern info))) 129 | (view first-pattern info)))) 130 | 131 | (defn map->view [this {:keys [output?] :as info}] 132 | `(do (check (map? ~input) ~this) 133 | (~(if output? 'assoc 'do) 134 | ~this 135 | ~@(aconcat (for [[key pattern] this] 136 | [key `(let-input (get ~input ~key) ~(view pattern (assoc info :remaining? false)))]))))) 137 | 138 | (extend-protocol-by-fn 139 | View 140 | (fn view [this {:keys [output?] :as info}] 141 | [nil Object] 142 | `(let [literal# '~this] 143 | (check (= literal# ~input) ~this) 144 | literal#) 145 | 146 | [ISeq IPersistentVector] 147 | `(do (check (seqable? ~input) ~this) 148 | (let-input (seq ~input) ~(seq->view (seq this) info))) 149 | 150 | [IPersistentMap] 151 | `(do ~(when (instance? IRecord this) `(check (instance? ~(class this) ~input) ~this)) 152 | ~(map->view this info)))) 153 | 154 | ;; LOGICAL PATTERNS 155 | 156 | (extend-protocol-by-fn 157 | View 158 | (fn view [{:keys [pattern patterns meta-pattern name code f min-count max-count refers] :as this} 159 | {:keys [name->view output? remaining?] :as info}] 160 | [Any] 161 | input 162 | 163 | [Is] 164 | `(do (check (~f ~input) ~this) 165 | ~input) 166 | 167 | [Guard] 168 | `(let [output# ~(view pattern info)] 169 | (check ~(let-bound (:bound-here (meta this)) code) ~this) 170 | output#) 171 | 172 | [Name] 173 | `(let [output# ~(view pattern (assoc info :output? true))] 174 | (.set ~name output#) 175 | output#) 176 | 177 | [Output] 178 | `(do ~(view pattern (assoc info :output? false)) 179 | (trap-failure ~(let-bound (:bound-here (meta this)) code))) 180 | 181 | [Or] 182 | (or->view patterns info) 183 | 184 | [And] 185 | (do (assert (not (empty? patterns)) "AND patterns must not be empty") 186 | `(do ~@(for [pattern patterns] 187 | `(clear-remaining remaining? ~(view pattern info))))) 188 | 189 | [WithMeta] 190 | `(~(if output? 'try-with-meta 'do) 191 | ~(view pattern info) 192 | 193 | (let-input (meta ~input) ~(view meta-pattern (assoc info :remaining? false)))) 194 | 195 | [Refer] 196 | (if remaining? 197 | `(~(name->view name) ~input nil) 198 | `(~(name->view name) ~input)) 199 | 200 | [Let] 201 | (let [name->view (merge name->view 202 | (for-map [[name pattern] refers] 203 | name (gensym name))) 204 | info (assoc info :name->view name->view)] 205 | `(letfn [~@(for [[name pattern] refers] 206 | `(~(name->view name) 207 | ([~input ~'_] 208 | ~(view-with-locals pattern (assoc info :remaining? true))) 209 | ([~input] 210 | ~(view-with-locals pattern (assoc info :remaining? false)))))] ;; refers is not walked by pattern/with-bound, so it is scoped separately 211 | ~(view pattern info))) 212 | 213 | [Rest] 214 | (view pattern (assoc info :remaining? true)) 215 | 216 | [Repeated] 217 | `(do (check (seqable? ~input) ~this) 218 | (loop [~input (seq ~input) 219 | loop-output# ~(if output? [] nil) 220 | loop-count# 0] 221 | (let [result# (try 222 | (do (check (< loop-count# ~max-count) this) 223 | ~(if (rest? pattern) 224 | (view pattern info) 225 | (view-first pattern info))) 226 | (catch Failure failure# failure#))] 227 | (if (instance? Failure result#) 228 | (do (check (>= loop-count# ~min-count) ~this) 229 | (pass-remaining ~remaining? ~input ~this) 230 | (seq loop-output#)) 231 | (recur 232 | ~(if (rest? pattern) `(let [remaining# (get-remaining)] (set-remaining nil) remaining#) `(next ~input)) 233 | (~(if output? (if (rest? pattern) 'into 'conj) 'comment) loop-output# result#) 234 | (unchecked-inc loop-count#)))))) 235 | 236 | [Trace] 237 | `(do (.set ~depth (inc (.x ~depth))) 238 | (println (apply str (repeat (.x ~depth) " ")) "=>" ~name ~input) 239 | (try 240 | (let [output# ~(view pattern info)] 241 | (println (apply str (repeat (.x ~depth) " ")) "<=" ~name output#) 242 | (.set ~depth (dec (.x ~depth))) 243 | output#) 244 | (catch Exception exc# 245 | (println (apply str (repeat (.x ~depth) " ")) "XX" ~name (pr-str exc#)) 246 | (.set ~depth (dec (.x ~depth))) 247 | (throw exc#)))))) -------------------------------------------------------------------------------- /src/strucjure/view/Failure.java: -------------------------------------------------------------------------------- 1 | package strucjure.view; 2 | 3 | import clojure.lang.RT; 4 | import clojure.lang.Var; 5 | 6 | public class Failure extends Exception { 7 | public static Var prstr = RT.var("clojure.core", "pr-str"); 8 | public String test; 9 | public String pattern; 10 | public Object input; 11 | public Failure lastFailure; 12 | 13 | public Failure(String test, String pattern, Object input, Failure lastFailure) { 14 | super(); 15 | this.test = test; 16 | this.pattern = pattern; 17 | this.input = input; 18 | this.lastFailure = lastFailure; 19 | } 20 | 21 | public String getMessage() { 22 | StringBuilder builder = new StringBuilder(); 23 | this.getMessage(builder); 24 | return builder.toString(); 25 | } 26 | 27 | public void getMessage(StringBuilder builder) { 28 | builder.append("\nFailed test " + test + " in pattern " + pattern + " on input " + prstr.invoke(input)); 29 | if (lastFailure != null) 30 | lastFailure.getMessage(builder); 31 | } 32 | } 33 | -------------------------------------------------------------------------------- /test/strucjure/test.clj: -------------------------------------------------------------------------------- 1 | (ns strucjure.test 2 | (:refer-clojure :exclude [with-meta * + or and name case keys]) 3 | (require [clojure.test :refer [deftest] :as t] 4 | [plumbing.core :refer [for-map aconcat map-vals]] 5 | [strucjure.pattern :refer :all] 6 | [strucjure.view :as view] 7 | [strucjure.sugar :refer :all])) 8 | 9 | ;; (t/test-ns 'strucjure.test) 10 | 11 | (defrecord Foo [x y]) 12 | (defrecord Bar [x y]) 13 | 14 | (deftest basics 15 | ;; equality 16 | 17 | (t/is (= (match 1 18 | :a :fail 19 | 1 :ok 20 | 'c :fail) 21 | :ok)) 22 | 23 | ;; wildcard 24 | 25 | (t/is (= (match 'c 26 | :a :fail 27 | 1 :fail 28 | _ :ok) 29 | :ok)) 30 | 31 | ;; is 32 | 33 | (t/is (= (match :x 34 | (is integer?) :fail 35 | (is keyword?) :ok) 36 | :ok)) 37 | 38 | ;; ordered choice 39 | 40 | (t/is (= (match :x 41 | (is integer?) :fail 42 | (is keyword?) :ok 43 | :x :not-reached) 44 | :ok)) 45 | 46 | ;; lists 47 | 48 | (t/is (= (match (list 1 2 3) 49 | (list 1 2) :too-short 50 | (list 1 2 3 4) :too-long 51 | (list 1 2 3) :just-right) 52 | :just-right)) 53 | 54 | ;; vecs 55 | 56 | (t/is (= (match [1 2 3] 57 | [1 2] :too-short 58 | [1 2 3 4] :too-long 59 | [1 2 3] :just-right) 60 | :just-right)) 61 | 62 | ;; maps 63 | 64 | (t/is (= (match {:a 1 :b 2} 65 | {:a 2} :wrong 66 | {:a 1} :no-b 67 | {:a 1 :b 2} :exact) 68 | :no-b ;; map patterns ignore extra keys 69 | )) 70 | 71 | (t/is (= (match {:a 1 :b 2} 72 | {:a 1 :c _} :huh?) 73 | :huh? ;; missing keys return nil which matches _. this is a deliberate choice to match destructuring semantics 74 | )) 75 | 76 | (t/is (= (match {:a 1 :b 2} 77 | {:a 1 :c not-nil} :fail 78 | _ :ok) 79 | :ok 80 | )) 81 | 82 | ;; records 83 | 84 | (t/is (= (match (Foo. 1 2) 85 | (Bar. 1 2) :fail 86 | (Foo. :a :b) :fail 87 | (Foo. 1 2) :ok) 88 | :ok 89 | )) 90 | 91 | (t/is (= (match (Foo. 1 2) 92 | (->Foo 1 2) :ok) 93 | :ok 94 | )) 95 | 96 | ;; TODO something is calling clojure.walk/walk on this record literal :( 97 | ;; (t/is (= (match (Foo. 1 2) 98 | ;; #strucjure.test.Foo{:x 1 :y 2} :ok))) 99 | 100 | (t/is (= (match (Foo. 1 2) 101 | {:x 1 :y 2} :ok))) 102 | 103 | ;; metadata 104 | 105 | (t/is (= (match (clojure.core/with-meta [1 2 3] {:foo true}) 106 | (with-meta _ {:foo _}) :ok) 107 | :ok)) 108 | 109 | ;;names 110 | 111 | (t/is (= (match [1 2 3] 112 | [1 ^x _ 3] x) 113 | 2)) 114 | 115 | (t/is (= (match [1 2 3] 116 | ^x [1 _ 3] x) 117 | (list 1 2 3) ;; names capture output, not input. vectors and lists both match any Seqable and always output a Seq. 118 | )) 119 | 120 | ;; guards 121 | 122 | (t/is (= (match [1 2 3] 123 | (guard [1 ^z _ ^y _] (= z y)) :fail 124 | [1 ^z _ ^y _] [z y]) 125 | [2 3])) 126 | 127 | ;; booleans 128 | 129 | (t/is (= (match [1 2 3] 130 | (or [] [1] [1 2] [1 2 3]) :ok) 131 | :ok)) 132 | 133 | ;; TODO figure out how to make this work with Refers 134 | ;; (t/is (thrown? java.lang.AssertionError ;; may not have different names in different branches of `or` 135 | ;; (macroexpand-1 136 | ;; '(match [1 2 3] 137 | ;; (or [] ^x [1] [1 2] [1 2 3]) x)))) 138 | 139 | (t/is (= (match {:a 1 :b 2} 140 | (and [[:a 1] [:b 2]] {:a 1 :b 2}) :ok) 141 | :ok ;; maps are sequences too 142 | )) 143 | 144 | ) 145 | 146 | (deftest repetition 147 | 148 | ;; rest 149 | 150 | (t/is (= (match [1 2 3] 151 | [1 (& ^z _)] z) 152 | (list 2 3))) 153 | 154 | (t/is (= (match [1 2 3] 155 | [1 ^z (& _)] z) 156 | (list 2 3) ;; regression test - naming a Rest pattern used to not work 157 | )) 158 | 159 | ;; greedy 160 | 161 | (t/is (= (match [1 2 3 4 5] 162 | [1 ^x (& [_ _]) ^y (& [_ _])] [x y]) 163 | [(list 2 3) (list 4 5)])) 164 | 165 | ;; repetition 166 | 167 | (t/is (= (match [1 2] 168 | ^z (* (is integer?)) z) 169 | (list 1 2))) 170 | 171 | (t/is (= (match [1 2 :x :y :z] 172 | [^ints (&* (is integer?)) ^keys (&* (is keyword?))] [ints keys]) 173 | [(list 1 2) (list :x :y :z)])) 174 | 175 | (t/is (= (match [1 2 1 2 1 2] 176 | ^z (*& [1 2]) z) 177 | (list 1 2 1 2 1 2))) 178 | 179 | (t/is (= (match [1 2 1 2 1 2 3] 180 | (*& [1 2]) :fail 181 | _ :ok) 182 | :ok)) 183 | 184 | (t/is (= (match [1 2 1 2 1 2 3] 185 | [^y (&*& [1 2]) ^z (& _)] [y z]) 186 | [(list 1 2 1 2 1 2) (list 3)])) 187 | 188 | ) 189 | 190 | (deftest named-patterns 191 | 192 | ;; basic 193 | 194 | (t/is (= (match [[1 2 3] [1 2 3]] 195 | (letp [foo [1 2 3]] 196 | [foo foo] :ok)) 197 | :ok)) 198 | 199 | ;; recursion 200 | 201 | (t/is (= (match '(succ (succ (succ zero))) 202 | (letp [num (or succ zero) 203 | succ (case ['succ num] (inc num)) 204 | zero (case 'zero 0)] 205 | num)) 206 | 3)) 207 | 208 | ;; parsing 209 | 210 | (t/is (= (match [1 2 3 :x :y :z] 211 | (letp [ints (* (is integer?)) 212 | keys (* (is keyword?))] 213 | ints :fail 214 | [(& ints)] :fail 215 | [(& ints) (& keys)] :ok)) 216 | :ok ;; tests that let-bound patterns are called with the right parsing context 217 | )) 218 | 219 | ) 220 | 221 | 222 | 223 | 224 | --------------------------------------------------------------------------------