(defn identity
"Returns its argument."
[x] x)
(defn constantly
"Returns a function that takes any number of arguments and always returns x."
[x] (fn [& _] x))
(defn complement
"Takes a function f and returns a function that takes the same args as f,
and returns the opposite truth value."
[f] (fn [& args] (not (apply f args))))
(defn some-fn
"Takes a set of predicates and returns a function f that returns the first
logical true value of applying one of its predicates to any of its
arguments, else nil."
([p] (fn [& args] (or (some p args) false)))
([p1 p2] (fn [& args] (or (some p1 args) (some p2 args) false)))
([p1 p2 p3] (fn [& args] (or (some p1 args) (some p2 args) (some p3 args) false)))
([p1 p2 p3 & ps]
(fn [& args]
(or (some p1 args) (some p2 args) (some p3 args)
(some (fn [p] (some p args)) ps) false))))
(defn every-pred
"Takes a set of predicates and returns a function f that returns true if
all of its predicates are satisfied by all of its arguments, else false."
([p] (fn [& args] (every? p args)))
([p1 p2] (fn [& args] (and (every? p1 args) (every? p2 args))))
([p1 p2 p3] (fn [& args] (and (every? p1 args) (every? p2 args) (every? p3 args))))
([p1 p2 p3 & ps]
(fn [& args]
(and (every? p1 args) (every? p2 args) (every? p3 args)
(every? (fn [p] (every? p args)) ps)))))
(defn not=
"Same as (not (= obj1 obj2))."
[& args] (not (apply = args)))
(defn comp
"Takes a set of functions and returns a fn that is the composition of
those fns. The returned fn takes any number of args, applies the
rightmost fn to the args, the next fn (right-to-left) to the result, etc."
([] identity)
([f] f)
([f g] (fn [& args] (f (apply g args))))
([f g & more]
(reduce comp (cons f (cons g more)))))
(defn partial
"Takes a function f and fewer than the normal arguments to f, and returns
a fn that takes a variable number of additional args and applies f to
args + additional args."
[f & args]
(fn [& more] (apply f (concat args more))))
;; reduce is a native builtin (supports reduced/early-termination)
(defn completing
"Takes a reducing function f (with 2-arg step arity) and returns a fn
with 0, 1, and 2 arities: 0-arg calls (f), 1-arg calls cf (default
identity) for completion, 2-arg calls f for the step."
([f] (completing f identity))
([f cf]
(fn
([] (f))
([result] (cf result))
([result input] (f result input)))))
(defn transduce
"reduce with a transformation of f (xf). If init is not supplied,
(f) will be called to produce it. f should be a reducing function
that accepts 0 and 2 arities. Returns the value obtained by applying
(xform f) to init and the elements of coll."
([xform f coll]
(transduce xform f (f) coll))
([xform f init coll]
(let [f (xform f)
ret (reduce f init coll)]
(f ret))))
(defn sequence
"Coerces coll to a (possibly empty) sequence, if it is not already one.
With a transducer, returns a lazy sequence of applications of the transform
to the items in coll(s)."
([coll] (or (seq coll) ()))
([xform coll]
(let [rf (xform conj)
result (reduce rf [] coll)
result (rf result)]
(or (seq (if (reduced? result) (unreduced result) result)) ()))))
(defn map
"Returns a lazy sequence consisting of the result of applying f to the
set of first items of each coll, followed by applying f to the set of
second items, until any one coll is exhausted. With one collection arg,
returns a transducer."
([f]
(fn [rf]
(fn
([] (rf))
([result] (rf result))
([result input] (rf result (f input)))
([result input & inputs] (rf result (apply f input inputs))))))
([f coll]
(lazy-seq
(when-let [s (seq coll)]
(cons (f (first s)) (map f (rest s))))))
([f c1 c2]
(lazy-seq
(let [s1 (seq c1) s2 (seq c2)]
(when (and s1 s2)
(cons (f (first s1) (first s2))
(map f (rest s1) (rest s2)))))))
([f c1 c2 c3]
(lazy-seq
(let [s1 (seq c1) s2 (seq c2) s3 (seq c3)]
(when (and s1 s2 s3)
(cons (f (first s1) (first s2) (first s3))
(map f (rest s1) (rest s2) (rest s3)))))))
([f c1 c2 c3 & colls]
(let [all-colls (list* c1 c2 c3 colls)]
(letfn [(map-step [seqs]
(lazy-seq
(let [ss (map seq seqs)]
(when (every? identity ss)
(cons (apply f (map first ss))
(map-step (map rest ss)))))))]
(map-step all-colls)))))
(defn filter
"Returns a lazy sequence of the items in coll for which (pred item)
returns logical true. With no coll, returns a transducer."
([pred]
(fn [rf]
(fn
([] (rf))
([result] (rf result))
([result input]
(if (pred input)
(rf result input)
result)))))
([pred coll]
;; Lazy, as the docstring says: an eager loop here never returns on an
;; infinite coll, so `(take 3 (filter even? (range)))` hangs the process.
(lazy-seq
(when-let [s (seq coll)]
(let [f (first s) r (rest s)]
(if (pred f)
(cons f (filter pred r))
(filter pred r)))))))
(defn remove
"Returns a lazy sequence of the items in coll for which (pred item)
returns logical false. With no coll, returns a transducer."
([pred] (filter (complement pred)))
([pred coll] (filter (complement pred) coll)))
(defn keep
"Returns a lazy sequence of the non-nil results of (f item). Note, this
means false return values will be included. With no coll, returns a
transducer."
([f]
(fn [rf]
(fn
([] (rf))
([result] (rf result))
([result input]
(let [v (f input)]
(if (nil? v) result (rf result v)))))))
([f coll]
(loop [s (seq coll) acc []]
(if s
(let [v (f (first s))]
(if (nil? v)
(recur (next s) acc)
(recur (next s) (conj acc v))))
(or (seq acc) '())))))
(defn cat
"A transducer which concatenates the contents of each input, which must
be a collection, into the reduction."
[rf]
(fn
([] (rf))
([result] (rf result))
([result input] (reduce rf result input))))
(defn mapcat
"Returns the result of applying concat to the result of applying map to f
and colls. Thus function f should return a collection. With no coll,
returns a transducer."
([f] (comp (map f) cat))
([f coll]
(when-not (ifn? f) (throw (str "Argument must be a function: " f)))
(let [s (seq coll)]
(letfn [(cat [xs colls]
(lazy-seq
(if-let [s (seq xs)]
(cons (first s) (cat (rest s) colls))
(when-let [cs (seq colls)]
(cat (f (first cs)) (rest cs))))))]
(cat nil s))))
([f c1 c2]
(when-not (ifn? f) (throw (str "Argument must be a function: " f)))
(letfn [(cat [xs s1 s2]
(lazy-seq
(if-let [s (seq xs)]
(cons (first s) (cat (rest s) s1 s2))
(when (and s1 s2)
(cat (f (first s1) (first s2))
(next s1) (next s2))))))]
(cat nil (seq c1) (seq c2))))
([f c1 c2 & colls]
(when-not (ifn? f) (throw (str "Argument must be a function: " f)))
(let [all-colls (cons c1 (cons c2 colls))
step (fn step [xs seqs]
(lazy-seq
(if-let [s (seq xs)]
(cons (first s) (step (rest s) seqs))
(when (every? seq seqs)
(step (apply f (map first seqs))
(map next seqs))))))]
(step nil (map seq all-colls)))))
(defn tree-seq
"Returns a lazy sequence of the nodes in a tree, via a depth-first walk.
branch? must be a fn of one arg that returns true if passed a node
that can have children (but may not). children must be a fn of one
arg that returns a sequence of the children. Will only be called on
nodes for which branch? returns true. Root is the root node of the
tree."
[branch? children root]
(let [walk (fn walk [node]
(lazy-seq
(cons node
(when (branch? node)
(mapcat walk (children node))))))]
(walk root)))
(defn take
"Returns a lazy sequence of the first n items in coll, or all items if
there are fewer than n. With no coll, returns a transducer."
([n]
(fn [rf]
(let [nv (volatile! n)]
(fn
([] (rf))
([result] (rf result))
([result input]
(let [n @nv
nn (vswap! nv dec)
result (if (pos? n) (rf result input) result)]
(if (not (pos? nn))
(ensure-reduced result)
result)))))))
([n coll]
(let [n (int n)]
(cond (pos? n)
(when (pos? n)
(lazy-seq
(when-let [s (seq coll)]
(cons (first s) (take (dec n) (rest s))))))
:else []))))
(defn drop
"Returns a lazy sequence of all but the first n items in coll. With no
coll, returns a transducer."
([n]
(fn [rf]
(let [nv (volatile! n)]
(fn
([] (rf))
([result] (rf result))
([result input]
(let [n (vswap! nv dec)]
(if (neg? n)
(rf result input)
result)))))))
([n coll]
(loop [s (seq coll) n (int n)]
(if (and s (pos? n))
(recur (next s) (dec n))
(or s '())))))
(defn take-while
"Returns a lazy sequence of successive items from coll while
(pred item) returns logical true. With no coll, returns a transducer."
([pred]
(fn [rf]
(fn
([] (rf))
([result] (rf result))
([result input]
(if (pred input)
(rf result input)
(reduced result))))))
([pred coll]
(lazy-seq
(when-let [s (seq coll)]
(let [x (first s)]
(when (pred x)
(cons x (take-while pred (rest s)))))))))
(defn drop-while
"Returns a lazy sequence of the items in coll starting from the first
item for which (pred item) returns logical false. With no coll, returns
a transducer."
([pred]
(fn [rf]
(let [dv (volatile! true)]
(fn
([] (rf))
([result] (rf result))
([result input]
(if (and @dv (pred input))
result
(do (vreset! dv false)
(rf result input))))))))
([pred coll]
(loop [s (seq coll)]
(if (and s (pred (first s)))
(recur (next s))
(or s '())))))
(defn dorun
"Walks through coll, realizing each lazy element, for side effects.
Returns nil."
[coll]
(loop [s (seq coll)]
(when s (recur (next s)))))
(defn doall
"Walks through coll, realizing every lazy element, for side effects.
Returns coll."
[coll]
(dorun coll)
coll)
(defn run!
"Runs the supplied procedure (via reduce), for purposes of side effects,
on successive items in coll. Returns nil."
[proc coll]
(reduce #(proc %2) nil coll)
nil)
(defn some
"Returns the first logical true value of (pred x) for any x in coll,
else nil."
[pred coll]
(loop [s (seq coll)]
(when s
(let [v (pred (first s))]
(if v v (recur (next s)))))))
(defn every?
"Returns true if (pred x) is logical true for every x in coll, else
false."
[pred coll]
(loop [s (seq coll)]
(if s
(if (pred (first s))
(recur (next s))
false)
true)))
(defn not-any?
"Returns true if (pred x) is logical false for every x in coll, else
false."
[pred coll] (not (some pred coll)))
(defn not-every?
"Returns true if (pred x) is logical false for at least one x in coll,
else false."
[pred coll] (not (every? pred coll)))
(defn mapv
"Returns a vector consisting of the result of applying f to the set of
first items of each coll, followed by applying f to the set of second
items, until any one coll is exhausted."
([f coll] (vec (map f coll)))
([f c1 c2] (vec (map f c1 c2)))
([f c1 c2 c3] (vec (map f c1 c2 c3)))
([f c1 c2 c3 & colls] (vec (apply map f c1 c2 c3 colls))))
(defn filterv
"Returns a vector of the items in coll for which (pred item) returns
logical true."
[pred coll] (vec (filter pred coll)))
(defn swap!
"Atomically swaps the value of atom to be (apply f current-value args)."
[a f & args] (reset! a (apply f (deref a) args)))
(defmacro when
"Evaluates test. If logical true, evaluates body in an implicit do."
[test & body]
(list 'if test (cons 'do body) nil))
(defmacro when-not
"Evaluates test. If logical false, evaluates body in an implicit do."
[test & body]
(list 'if test nil (cons 'do body)))
(defmacro if-not
"Evaluates test. If logical false, evaluates and returns then, otherwise
else (default nil)."
([test then] (list 'if test nil then))
([test then else] (list 'if test else then)))
(defmacro declare
"defs the supplied var names with no bindings, useful for making forward declarations."
[& names]
(cons 'do (map (fn [n] (list 'def n)) names)))
(defmacro if-let
"bindings => binding-form test. If test is logical true, evaluates then
with binding-form bound to the value of test, otherwise else."
([bindings then] (list 'if-let bindings then nil))
([bindings then else]
(let [form (nth bindings 0)
tst (nth bindings 1)
temp (gensym "if_let__")]
(list 'let (vector temp tst)
(list 'if temp
(list 'let (vector form temp) then)
else)))))
(defmacro when-let
"bindings => binding-form test. If test is logical true, evaluates body
with binding-form bound to the value of test."
[bindings & body]
(list 'if-let bindings (cons 'do body)))
(defmacro cond
"Takes a set of test/expr pairs. Evaluates each test one at a time. If a
test returns logical true, evaluates and returns the value of the
corresponding expr and doesn't evaluate any of the other tests or exprs.
Returns nil if no test is true."
[& clauses]
(when (seq clauses)
(list 'if (first clauses)
(if (next clauses)
(second clauses)
(throw (ex-info "cond requires even number of clauses" {})))
(cons 'cond (next (next clauses))))))
(defmacro condp
"Takes a binary predicate, an expression, and a set of test-expr/result-expr
clauses. For each clause, (pred test-expr expr) is evaluated; the first
clause for which this is logical true has its result-expr evaluated and
returned. An odd trailing clause is a default expression evaluated if no
clause matches; otherwise throws."
[pred expr & clauses]
(if (seq clauses)
(if (next clauses)
(list 'if (list pred (first clauses) expr)
(second clauses)
(cons 'condp (cons pred (cons expr (next (next clauses))))))
(first clauses))
(throw (ex-info "condp: no matching clause" {}))))
(defmacro case
"Takes an expression and a set of test-constant/result-expr clauses (test
constants may be lists of alternatives). Matches expr against the test
constants using an equality check and evaluates the corresponding
result-expr. An odd trailing clause is a default expression evaluated if
no clause matches; otherwise throws."
[expr & clauses]
(let [e (gensym)
quote-const (fn [c]
;; Quote symbols and lists so they aren't evaluated.
;; Keywords, numbers, strings, chars, booleans, nil, vectors,
;; maps, and sets are self-evaluating and need no quoting.
(if (or (symbol? c) (list? c))
(list 'quote c)
c))
build (fn build [cs]
(if (seq cs)
(if (next cs)
(let [test-expr (first cs)
then-expr (second cs)
rest-cs (next (next cs))]
;; A list test means multiple alternatives: (a b c) matches a OR b OR c
;; UNLESS it's a list wrapped in another list: ((list of things)) matches the inner list literally
(if (and (list? test-expr) (not (nil? (seq test-expr))))
(if (and (= 1 (count test-expr)) (list? (first test-expr)))
;; ((inner-list)) — match the inner list literally
(list 'if (list 'case= e (quote-const (first test-expr)))
then-expr
(build rest-cs))
;; (a b c) — match any of the alternatives
(list 'if (cons 'or (map (fn [c] (list 'case= e (quote-const c))) test-expr))
then-expr
(build rest-cs)))
(list 'if (list 'case= e (quote-const test-expr))
then-expr
(build rest-cs))))
;; odd trailing form = default expression
(first cs))
(list 'throw (list 'new 'Exception (list 'str "No matching clause: " e)))))]
(list 'let (vector e expr)
(build clauses))))
(defmacro ->
"Threads x through the forms. Inserts x as the second item in the first
form, making a list of it if it is not a list already. If there are more
forms, inserts the first form as the second item in second form, etc."
([x] x)
([x form & more]
(let [threaded (if (seq? form)
(with-meta (list* (first form) x (next form)) (meta form))
(list form x))]
(if (seq more)
(list* '-> threaded more)
threaded))))
(defmacro ->>
"Threads x through the forms. Inserts x as the last item in the first
form, making a list of it if it is not a list already. If there are more
forms, inserts the first form as the last item in second form, etc."
([x] x)
([x form & more]
(let [threaded (if (seq? form)
(with-meta (concat (list (first form)) (next form) (list x)) (meta form))
(list form x))]
(if (seq more)
(list* '->> threaded more)
threaded))))
(defmacro as->
"Binds name to expr, evaluates the first form in the lexical context of
that binding, then binds name to that result, repeating for each
successive form, returning the result of the last form."
[expr name & forms]
(list 'let (vector name expr)
(if (seq forms)
(list* 'as-> name forms)
name)))
(defmacro doto
"Evaluates x, then calls each of the forms with x as the first argument,
presumably for side effects. Returns the evaluated x."
[x & forms]
(let [gx (gensym)]
(list 'let (vector gx x)
(cons 'do (map (fn [f]
(if (seq? f)
(cons (first f) (cons gx (rest f)))
(list f gx)))
forms)))))
(defmacro dotimes
"bindings => name n. Repeatedly executes body (presumably for side
effects) with name bound to integers from 0 through n-1."
[bindings & body]
(let [i (first bindings)
n (second bindings)]
(list 'loop (vector i 0)
(list 'when (list '< i n)
(cons 'do body)
(list 'recur (list 'inc i))))))
(defmacro doseq
"bindings => binding-form coll-expr [modifier binding-form coll-expr]*.
Repeatedly executes body (presumably for side effects) with bindings and
filtering as provided by \"for\". Supports :let, :while, and :when
modifiers. Returns nil."
[bindings & body]
(letfn [(emit [binds recur-form]
(if (seq binds)
(let [tag (first binds)]
(cond
(= :when tag)
;; :when — skip element but continue loop
(let [expr (second binds)]
(list 'do
(list 'when expr (emit (next (next binds)) nil))
recur-form))
(= :while tag)
;; :while — stop loop entirely when false
(let [expr (second binds)]
(list 'when expr (emit (next (next binds)) recur-form)))
(= :let tag)
(let [let-binds (second binds)]
(list 'let let-binds (emit (next (next binds)) recur-form)))
:else
(let [x tag
coll (second binds)
rest-binds (next (next binds))
gs (gensym "s__")
inner-loop (list 'loop (vector gs (list 'seq coll))
(list 'when gs
(list 'let (vector x (list 'first gs))
(emit rest-binds (list 'recur (list 'next gs))))))]
(if recur-form
(list 'do inner-loop recur-form)
inner-loop))))
(list 'do (cons 'do body) recur-form)))]
(emit (seq bindings) nil)))
(defmacro for
"bindings => binding-form coll-expr [modifier binding-form coll-expr]*
List comprehension. Takes a vector of one or more binding-form/collection-expr
pairs, each followed by zero or more modifiers, and yields a lazy sequence of
evaluations of body. Collections are iterated in a nested fashion, rightmost
fastest. Supports :let, :when and :while modifiers, like doseq.
(for [x (range 3) y (range 2)] [x y])
;=> ([0 0] [0 1] [1 0] [1 1] [2 0] [2 1])
(for [x (range 10) :when (even? x) :let [y (* x x)]] y)
;=> (0 4 16 36 64)
:when skips an element and keeps iterating; :while stops the loop it belongs
to. A :while must follow its binding directly, and a binding takes at most
one :while; any number of :let modifiers may sit in between.
The emitted symbols are namespace-qualified, so a binding may be named after
a core function without breaking the expansion."
[bindings & body]
(letfn [(emit [binds]
(if (seq binds)
(if (next binds)
(let [tag (first binds)]
(cond
(= :let tag)
(list 'let (second binds) (emit (next (next binds))))
(= :when tag)
;; Skip this element, keep iterating: nil concatenates away.
(list 'if (second binds) (emit (next (next binds))) nil)
(= :while tag)
(throw (ex-info
(str "for: a :while must follow its binding directly "
"(only :let may come between) and a binding takes "
"at most one :while")
{:modifier :while :bindings bindings}))
:else
(let [x tag
coll (second binds)
after (next (next binds))]
;; Gather the :let modifiers sitting between this binding
;; and a possible :while, so the :while test can see what
;; they bind.
(loop [lets [] more after]
(cond
(= :let (first more))
(recur (into lets (second more)) (next (next more)))
(= :while (first more))
;; One frame per element, so a :let init runs exactly
;; once and both the test and the body read it from
;; the same scope. A frame is [contribution] while the
;; test holds and nil once it fails, and that is the
;; difference that lets :while stop the loop while an
;; inner :when — whose contribution is an empty seq,
;; not nil — only skips.
(list 'clojure.core/mapcat 'clojure.core/first
(list 'clojure.core/take-while 'clojure.core/some?
(list 'clojure.core/map
(list 'fn (vector x)
(list 'let lets
(list 'if (second more)
(vector (emit (next (next more))))
nil)))
coll)))
(seq after)
(list 'clojure.core/mapcat
(list 'fn (vector x) (emit after))
coll)
:else
;; Innermost binding with no modifiers: exactly one
;; element per element, which is what map is. Routing
;; it through mapcat costs a per-element list and
;; gives up the pinned arity-2 map fast path in the
;; IR interpreter and in codegen.
(list 'clojure.core/map
(list 'fn (vector x) (cons 'do body))
coll))))))
(throw (ex-info
"for requires an even number of forms in the binding vector"
{:bindings bindings})))
;; Innermost: one element per surviving binding combination.
(list 'clojure.core/list (cons 'do body))))]
(emit (seq bindings))))
(defn second
"Same as (first (rest x))."
[coll] (first (rest coll)))
(defn third
"Same as (first (rest (rest x)))."
[coll] (first (rest (rest coll))))
(defn ffirst
"Same as (first (first x))."
[coll] (first (first coll)))
(defn nfirst
"Same as (next (first x))."
[coll] (next (first coll)))
(defn fnext
"Same as (first (next x))."
[coll] (first (next coll)))
(defn nnext
"Same as (next (next x))."
[coll] (next (next coll)))
(defn nthnext
"Returns the nth next of coll, (seq coll) when n is 0."
[coll n]
(if (and (some? coll) (nil? n))
(throw (str "arg 2 must not be nil"))
(loop [s (seq coll) n n]
(if (and s (pos? n))
(recur (next s) (dec n))
s))))
(defn butlast
"Returns a seq of all but the last item in coll."
[coll]
(loop [s (seq coll) acc []]
(if (next s)
(recur (next s) (conj acc (first s)))
(seq acc))))
(defn drop-last
"Returns a seq of all but the last n (default 1) items in coll."
([coll] (drop-last 1 coll))
([n coll]
(let [s (seq coll)]
(if s
(take (- (count s) n) s)
'()))))
(defn take-last
"Returns a seq of the last n items in coll."
[n coll]
(let [s (seq coll)]
(loop [s s lead (nthnext s n)]
(if lead
(recur (next s) (next lead))
s))))
(defmacro lazy-seq
"Takes a body of expressions that returns an ISeq or nil, and yields a
seqable object that invokes the body only the first time seq is called,
caching the result and returning it on all subsequent seq calls."
[& body]
(list 'make-lazy-seq (list 'fn [] (cons 'do body))))
(defn iterate
"Returns a lazy sequence of x, (f x), (f (f x)), etc."
[f x]
(lazy-seq (cons x (lazy-seq (iterate f (f x))))))
(defn repeat
"Returns a lazy (infinite, or length n if supplied) sequence of xs."
([x] (lazy-seq (cons x (repeat x))))
([n x] (take n (repeat x))))
(defn repeatedly
"Takes a function of no args and returns a lazy (infinite, or length n
if supplied) sequence of calls to it."
([f] (lazy-seq (cons (f) (repeatedly f))))
([n f] (take n (repeatedly f))))
(defn range
"Returns a lazy seq of nums from start (inclusive, default 0) to end
(exclusive) by step (default 1). Without end, returns an effectively
infinite sequence."
([] (range 0 9223372036854775807 1))
([end] (range 0 end 1))
([start end] (range start end 1))
([start end step]
(lazy-seq
(when (if (pos? step) (< start end) (> start end))
(cons start (range (+ start step) end step))))))
(defn cycle
"Returns a lazy (infinite) sequence of repetitions of the items in
coll."
[coll]
(letfn [(c [s]
(lazy-seq
(if (seq s)
(cons (first s) (c (rest s)))
(c coll))))]
(when (seq coll) (c coll))))
(defn counted?
"Returns true if coll implements count in constant time."
[x] (or (vector? x) (map? x) (set? x) (seq? x)))
(defn reversible?
"Returns true if coll implements rseq (reverse in constant time)."
[x] (or (vector? x) (sorted-map? x) (sorted-set? x)))
(defn sequential?
"Returns true if coll implements the sequential interface (vector, seq)."
[x] (or (seq? x) (vector? x)))
(defn associative?
"Returns true if coll implements the associative interface (map, vector)."
[x] (or (map? x) (vector? x)))
;; meta and vary-meta are native builtins (see builtins.rs)
(defn seqable?
"Returns true if seq can be called on x."
[x]
(or (nil? x) (seq? x) (vector? x) (map? x) (set? x) (string? x) (array? x)))
(defn nthrest [coll n]
(when-not (number? n) (throw (str "n must be a number, got: " (type n))))
(if (nil? coll)
(if (pos? n) (quote ()) nil)
(loop [s (seq coll) n n]
(if (and s (pos? n))
(recur (next s) (dec n))
(or s (quote ()))))))
(defn split-at
"Returns a vector of [(take n coll) (drop n coll)]."
[n coll]
[(take n coll) (drop n coll)])
(defn split-with
"Returns a vector of [(take-while pred coll) (drop-while pred coll)]."
[pred coll]
[(take-while pred coll) (drop-while pred coll)])
(defn partition
"Returns a seq of lists of n items each, at offsets step apart (default
step = n); drops a trailing partial partition unless pad is supplied, in
which case it's padded (and possibly still trailing-partial) with items
from pad."
([n coll]
(partition n n coll))
([n step coll]
;; Lazy: `(take 4 (partition 2 (range)))` must terminate.
(lazy-seq
(when-let [s (seq coll)]
(let [p (doall (take n s))]
(when (= n (count p))
(cons p (partition n step (nthnext s step))))))))
([n step pad coll]
(lazy-seq
(when-let [s (seq coll)]
(let [p (doall (take n s))]
(if (= n (count p))
(cons p (partition n step pad (nthnext s step)))
(list (doall (take n (concat p pad))))))))))
(defn partition-all
([n]
(fn [rf]
(let [a (volatile! [])]
(fn
([] (rf))
([result]
(let [result (if (seq @a)
(let [v @a]
(vreset! a [])
(unreduced (rf result v)))
result)]
(rf result)))
([result input]
(let [buf (vswap! a conj input)]
(if (= (count buf) n)
(do (vreset! a [])
(rf result buf))
result)))))))
([n coll]
(partition-all n n coll))
([n step coll]
(lazy-seq
(when-let [s (seq coll)]
(let [p (doall (take n s))]
(cons p (partition-all n step (nthnext s step))))))))
(defn flatten
"Takes any nested combination of sequential things (lists, vectors,
etc.) and returns their contents as a single, flat sequence."
[x]
(if (coll? x)
(mapcat flatten x)
(list x)))
(defn distinct
"Returns a seq of the elements of coll with duplicates removed. Returns
a transducer when no collection is provided."
([]
(fn [rf]
(let [seen (volatile! #{})]
(fn
([] (rf))
([result] (rf result))
([result input]
(if (contains? @seen input)
result
(do (vswap! seen conj input)
(rf result input))))))))
([coll]
(loop [s (seq coll) seen #{} acc []]
(if s
(let [v (first s)]
(if (contains? seen v)
(recur (next s) seen acc)
(recur (next s) (conj seen v) (conj acc v))))
(seq acc)))))
(defn dedupe
"Returns a lazy sequence removing consecutive duplicates in coll.
Returns a transducer when no collection is provided."
([]
(fn [rf]
(let [pv (volatile! ::none)]
(fn
([] (rf))
([result] (rf result))
([result input]
(let [prior @pv]
(vreset! pv input)
(if (= prior input)
result
(rf result input))))))))
([coll]
(sequence (dedupe) coll)))
(defn partition-by
"Applies f to each value in coll, splitting it each time f returns a
new value. Returns a lazy sequence of partitions. Returns a transducer
when no collection is provided."
([f]
(fn [rf]
(let [started (volatile! false)
a (volatile! [])
pv (volatile! nil)]
(fn
([] (rf))
([result]
(let [result (if (seq @a)
(let [v @a]
(vreset! a [])
(unreduced (rf result v)))
result)]
(rf result)))
([result input]
(let [pval @pv
val (f input)]
(vreset! pv val)
(if (or (not @started) (= val pval))
(do (vreset! started true)
(vswap! a conj input)
result)
(let [v @a]
(vreset! a [input])
(rf result v)))))))))
([f coll]
(lazy-seq
(when-let [s (seq coll)]
(let [fst (first s)
fv (f fst)
run (cons fst (take-while #(= fv (f %)) (rest s)))]
(cons (vec run)
(partition-by f (drop (count run) s))))))))
(defn map-indexed
"Returns a lazy sequence of (f index item) for each item in coll.
Returns a transducer when no collection is provided."
([f]
(fn [rf]
(let [i (volatile! -1)]
(fn
([] (rf))
([result] (rf result))
([result input]
(rf result (f (vswap! i inc) input)))))))
([f coll]
(let [idx (volatile! -1)]
(map (fn [x] (f (vswap! idx inc) x)) coll))))
(defn max
"Returns the greatest of the nums."
[& args] (reduce (fn [a b]
(cond
(NaN? a) a
(NaN? b) b
(>= a b) a
:else b))
args))
(defn min
"Returns the least of the nums."
[& args] (reduce (fn [a b]
(cond
(NaN? a) a
(NaN? b) b
(<= a b) a
:else b))
args))
(defmacro assert
"Evaluates test. If it does not return logical true, throws an
ex-info with an optional message."
[test & args]
(let [msg (first args)]
(list 'when (list 'not test)
(list 'throw (list 'ex-info (or msg "assertion failed") {})))))
(defn frequencies
"Returns a map from distinct items in coll to the number of times they
appear."
[coll]
(reduce (fn [m v] (assoc m v (inc (get m v 0)))) {} coll))
(defn group-by
"Returns a map of the elements of coll keyed by the result of f on each
element; the value at each key is a vector of the corresponding elements,
in the order they appeared in coll."
[f coll]
(reduce (fn [m v]
(let [k (f v)]
(assoc m k (conj (get m k []) v))))
{} coll))
(defn index-of
"Returns the index of the first occurrence of v in coll, or -1 if not
found."
[coll v]
(loop [s (seq coll) i 0]
(if s
(if (= (first s) v) i (recur (next s) (inc i)))
-1)))
(defn keep-indexed
"Returns a lazy sequence of the non-nil results of (f index item).
Returns a transducer when no collection is provided."
([f]
(fn [rf]
(let [i (volatile! -1)]
(fn
([] (rf))
([result] (rf result))
([result input]
(let [idx (vswap! i inc)
v (f idx input)]
(if (nil? v)
result
(rf result v))))))))
([f coll]
(loop [s (seq coll) i 0 acc []]
(if s
(let [v (f i (first s))]
(if (nil? v)
(recur (next s) (inc i) acc)
(recur (next s) (inc i) (conj acc v))))
(seq acc)))))
(defn reduce-kv [f init m]
(reduce (fn [acc kv] (f acc (first kv) (second kv))) init m))
(defn update
"Returns a new structure with the value at key updated by applying f to
the existing value (get m k), plus any supplied args."
[m k f & args]
(assoc m k (apply f (get m k) args)))
(defn update-in
"Returns a new nested structure with the value at the given key sequence
updated by applying f to the existing value there, plus any supplied
args. Missing intermediate levels are created as maps."
[m ks f & args]
(let [k (first ks)
ks (rest ks)]
(if (seq ks)
(assoc m k (apply update-in (get m k {}) ks f args))
(assoc m k (apply f (get m k) args)))))
(defn merge-with
"Returns a map that consists of the rest of the maps conj-ed onto the
first. If a key occurs in more than one map, the mapping(s) from the
latter (left-to-right) will be combined with the mapping in the result
by calling (f val-in-result val-in-latter)."
[f & maps]
(when (some identity maps)
(let [merge-entry (fn [m e]
(let [k (key e) v (val e)]
(if (contains? m k)
(assoc m k (f (get m k) v))
(assoc m k v))))
merge2 (fn [m1 m2] (reduce merge-entry (or m1 {}) (seq m2)))]
(reduce merge2 (filter identity maps)))))
(defn update-keys
"Returns a map with the keys mapped by f, values unchanged. f must
return a distinct key for each key of m, or entries are lost."
[m f]
(reduce-kv (fn [acc k v] (assoc acc (f k) v)) {} m))
(defn update-vals
"Returns a map with the values mapped by f, keys unchanged."
[m f]
(reduce-kv (fn [acc k v] (assoc acc k (f v))) {} m))
(defn juxt
"Takes a set of functions and returns a fn that is the juxtaposition of
those fns. The returned fn takes a variable number of args, and returns
a vector containing the result of applying each fn to the args."
[& fns]
(fn [& args] (mapv (fn [f] (apply f args)) fns)))
(defn fnil
"Takes a function f and one or more default values, and returns a fn
that calls f, replacing any nil arguments with the corresponding
default value."
[f default & defaults]
(let [all-defaults (cons default defaults)
n (count all-defaults)
patch (fn patch [args defs]
(if (seq defs)
(cons (if (nil? (first args)) (first defs) (first args))
(patch (rest args) (rest defs)))
args))]
(fn [& args]
(apply f (patch args all-defaults)))))
(defn memoize
"Returns a memoized version of a referentially transparent function f.
The memoized version caches the results of f keyed on the argument list,
and returns the cached result on subsequent calls with the same
arguments instead of calling f again."
[f]
(let [cache (atom {})]
(fn [& args]
(if (contains? @cache args)
(get @cache args)
(let [result (apply f args)]
(swap! cache assoc args result)
result)))))
(defn some? [x] (not (nil? x)))
(defn any? [x] true)
(defn str? [x] (string? x))
;; int?, double?, decimal?, ratio? are native builtins
(defn pos-int? [x] (and (int? x) (pos? x)))
(defn neg-int? [x] (and (int? x) (neg? x)))
(defn nat-int? [x] (and (int? x) (not (neg? x))))
;; zero? is a native builtin
(defn NaN? [x] (and (float? x) (not (= x x))))
(defn infinite? [x] (and (float? x) (or (= x ##Inf) (= x ##-Inf))))
(defn finite? [x] (and (float? x) (not (NaN? x)) (not (infinite? x))))
(defn qualified-symbol? [x]
(and (symbol? x) (not (nil? (namespace x)))))
(defn simple-symbol? [x]
(and (symbol? x) (nil? (namespace x))))
(defn qualified-keyword? [x]
(and (keyword? x) (not (nil? (namespace x)))))
(defn simple-keyword? [x]
(and (keyword? x) (nil? (namespace x))))
(defn println-str [& args]
(str (apply str (interpose " " (map (fnil str "nil") args))) "\n"))
(defn print-str [& args]
(apply str (interpose " " (map (fnil str "nil") args))))
(defn interpose
"Returns a lazy sequence of the elements of coll separated by sep.
Returns a transducer when no collection is provided."
([sep]
(fn [rf]
(let [started (volatile! false)]
(fn
([] (rf))
([result] (rf result))
([result input]
(if @started
(let [sepr (rf result sep)]
(if (reduced? sepr)
sepr
(rf sepr input)))
(do (vreset! started true)
(rf result input))))))))
([sep coll]
(loop [s (next (seq coll))
acc (if (seq coll) [(first coll)] [])]
(if s
(recur (next s) (conj (conj acc sep) (first s)))
(or (seq acc) [])))))
(defn random-sample
"Returns items from coll for which (rand) < prob. Returns a transducer
when no collection is provided."
([prob]
(filter (fn [_] (< (rand) prob))))
([prob coll]
(filter (fn [_] (< (rand) prob)) coll)))
(defn take-nth
"Returns a lazy sequence of every nth item in coll. Returns a transducer
when no collection is provided."
([n]
(fn [rf]
(let [i (volatile! -1)]
(fn
([] (rf))
([result] (rf result))
([result input]
(let [idx (vswap! i inc)]
(if (zero? (rem idx n))
(rf result input)
result)))))))
([n coll]
(lazy-seq
(when-let [s (seq coll)]
(cons (first s) (take-nth n (drop n s)))))))
(defn clojure-version
"Returns the version string of this implementation."
[] "cljx-0.1.0")
;; ── Phase 7: Concurrency primitives ──────────────────────────────────────────
(defmacro delay [& body]
(list 'make-delay (list 'fn [] (cons 'do body))))
(defn delay? [x] (= (type x) 'Delay))
(defn promise? [x] (= (type x) 'Promise))
;; ── multimethods: defmulti/defmethod over multi-fn and add-method ────────────
;; Neither surface form needs the interpreter. `multi-fn` mints a MultiFn and
;; `def` binds it; `add-method` writes one entry into the method table, keyed
;; the same way `remove-method` reads it. Naming the multimethod by SYMBOL in
;; the expansion is what makes `(defmethod other.ns/m ...)` work: the symbol
;; resolves through the ordinary rules, aliases included, where the old special
;; form looked the whole string up as an intern of the current namespace.
(defmacro defmulti [mname & body]
;; (defmulti name docstring? attr-map? dispatch-fn & options)
;;
;; A leading string is ALWAYS the docstring, even with nothing after it, so
;; `(defmulti area "Area.")` reports a missing dispatch function instead of
;; deferring the error to the first call, where a string is not callable.
;;
;; A map is the attr-map only when a form still FOLLOWS it. A map is itself
;; callable, so `(defmulti lookup {:a :first})` is a legitimate map-valued
;; dispatch function and must not be read as an attr-map with no dispatch.
;; That asymmetry is the whole subtlety here: the string case is decided by
;; the type alone, the map case needs the lookahead.
(let [docstring (when (string? (first body)) (first body))
after-doc (if docstring (next body) body)
attr-map (when (and (map? (first after-doc)) (next after-doc))
(first after-doc))
tail (if attr-map (next after-doc) after-doc)
dispatch (first tail)
;; A one-element vector marks PRESENCE, so `:default nil` still counts.
default (loop [o (next tail)]
(cond
(nil? o) nil
(= (first o) :default) [(second o)]
:else (recur (next (next o)))))
;; Precedence, not merely presence: the attr map sits on top of the
;; name's own `^` marks, and an explicit docstring beats a :doc the
;; attr map carries.
marks (merge (meta mname) attr-map)
merged (if docstring (assoc (or marks {}) :doc docstring) marks)
;; The metadata belongs on the var `def` binds, so it rides on the
;; name symbol; `nsym` is the bare name the multi-fn reports.
bare (with-meta (symbol (name mname)) (or merged {}))
nsym (list 'quote (symbol (name mname)))]
(if (nil? tail)
(throw (ex-info "defmulti requires a dispatch function"
{:name (symbol (name mname))}))
(list 'def bare
(if default
(list 'multi-fn nsym dispatch (first default))
(list 'multi-fn nsym dispatch))))))
(defn defmethod-pin
"The version pin on a `defmethod` target, or nil.
Two spellings, and only one of them is visible as an `@`. `f@abc1234` keeps
the version in a field of its own that `name` does not report, so the symbol
prints longer than `ns/name` rebuilds it. `v1/render` carries no `@` at all:
the require registered the namespace under its literal versioned name and
pointed the alias straight at it, so the pin sits in the namespace the alias
resolves to."
[sym]
(let [bare (if (namespace sym)
(str (namespace sym) "/" (name sym))
(name sym))
owner (when-let [a (namespace sym)]
(when-let [n (get (ns-aliases *ns*) (symbol a))]
(str (ns-name n))))]
(cond
;; `name` drops a version wherever it appears, so a name that survives
;; the round trip unchanged carried no pin. Core only: this runs during
;; macroexpansion in whatever namespace the caller is in, which need not
;; have clojure.string loaded.
(not= (str sym) bare) [:name (str sym)]
(and owner (not= owner (name (symbol owner)))) [:namespace owner]
:else nil)))
(defmacro defmethod [mname dispatch-val params & body]
;; A pin is a promise that the thing behind it does not change. Extending a
;; pinned multimethod would break that promise for every other holder of the
;; same pin, so it is refused rather than silently unpinned. The refusal is
;; here, before `add-method`, which is handed the resolved MultiFn and can no
;; longer tell how it was named.
(let [pin (defmethod-pin mname)]
(cond
(= (first pin) :name)
(throw (ex-info (str "defmethod cannot extend the versioned name "
(second pin))
{:target (second pin)}))
(= (first pin) :namespace)
(throw (ex-info (str "defmethod cannot extend a multimethod owned by the "
"versioned namespace " (second pin))
{:namespace (second pin)}))
;; No `resolve` check on the target here, deliberately. It would read the
;; namespace off `*ns*`, and the expansion resolves the symbol against the
;; namespace the form was WRITTEN in, which is not the same thing: inside
;; a `deftest` body `*ns*` is `user`, so a check would call every target
;; undefined. Letting the emitted symbol resolve is what keeps the alias,
;; refer and privacy rules in one place.
:else
(list 'add-method mname dispatch-val
(cons 'fn (cons (symbol (name mname)) (cons params body)))))))
;; ── protocols: defprotocol as a macro over the protocol* primitive ───────────
;; `protocol*` mints the protocol object in the CURRENT namespace, and that is
;; the one part a Clojure macro cannot do for itself: `Protocol.ns` is what
;; qualifies a method name for extend-via-metadata dispatch. The rest is
;; grammar - dropping the docstring, reading the option pairs, deriving each
;; method's arity from its parameter vector, and interning the protocol plus one
;; dispatch fn per method - so it lives here.
(defn protocol-method-spec
"Read a (method-name [params] \"doc\"?) form into
{:name \"method-name\" :min-arity n :variadic bool}. The arity comes from the
FIRST parameter vector; a spec carrying none counts as one fixed argument."
[form]
(let [amp? (fn [p] (= p '&))
params (first (filter vector? form))]
{:name (name (first form))
:min-arity (if params (count (remove amp? params)) 1)
:variadic (boolean (some amp? params))}))
(defn protocol-body
"Split a defprotocol body (everything after the name) into [opts specs]. A
leading docstring is dropped, flat :keyword value pairs collect into opts, and
every remaining list is read as a method spec."
[body]
(loop [b (seq (if (string? (first body)) (rest body) body)) opts {} specs []]
(cond
(nil? b) [opts specs]
(keyword? (first b)) (recur (next (next b))
(assoc opts (first b) (second b))
specs)
(seq? (first b)) (recur (next b) opts
(conj specs (protocol-method-spec (first b))))
:else (recur (next b) opts specs))))
(defmacro defprotocol [psym & body]
;; `bare` drops any annotation on the name before it is REFERRED to: the
;; metadata belongs on the var `def` binds, and `(var ^:marker P)` is not a
;; var reference.
(let [parts (protocol-body body)
opts (first parts)
specs (second parts)
bare (symbol (name psym))]
(cons 'do
(concat
[(list 'def psym
(list 'protocol* bare specs
(boolean (:extend-via-metadata opts))))]
(map (fn [s]
(list 'def (symbol (:name s))
(list 'protocol-fn bare (:name s))))
specs)
[(list 'var bare)]))))
;; ── protocol extension: extend-type/extend-protocol over the `extend` primitive
;; The irreducible operation is `extend`: bind {method-name -> fn} into a
;; protocol's impl table under a type tag. Both surface forms are the same
;; regrouping of one flat spec list — they differ only in which side is the
;; constant and which side repeats — so they are Clojure macros over that single
;; primitive rather than two bespoke Rust special forms.
(defn extend-spec-groups
"Split a flat extend spec list into ([head impls] ...). Each head is a symbol
and impls are the method forms that follow it, in source order."
[specs]
(loop [s (seq specs) head nil acc [] out []]
(cond
(nil? s) (if head (conj out [head acc]) out)
(symbol? (first s)) (recur (next s) (first s) []
(if head (conj out [head acc]) out))
:else (recur (next s) head (conj acc (first s)) out))))
(defn extend-impl-map
"Collapse method forms ((m [a] ...) (m [a b] ...)) into
{:m (fn ([a] ...) ([a b] ...))} — one entry per method name, arities in
source order."
[impls]
(let [mname (fn [i] (name (first i)))
names (distinct (map mname impls))]
(zipmap (map keyword names)
(map (fn [n]
(cons 'fn (map rest (filter (fn [i] (= n (mname i))) impls))))
names))))
(defmacro extend-type [tsym & specs]
(cons 'do
(map (fn [g]
(list 'extend (list 'quote tsym) (first g)
(extend-impl-map (second g))))
(extend-spec-groups specs))))
(defmacro extend-protocol [psym & specs]
(cons 'do
(map (fn [g]
(list 'extend (list 'quote (first g)) psym
(extend-impl-map (second g))))
(extend-spec-groups specs))))
;; ── Phase 6 (built-in protocols): ICounted, ILookup, ISeqable ────────────────
;; Written over the primitives rather than through `defprotocol` /
;; `extend-protocol`, on purpose. Those macros expand with interpreted
;; `map` / `zipmap` / `distinct`, and the tree-walker re-expands a macro on
;; every use, so the five forms below cost ~87ms of every runtime's startup
;; when spelled as macros (measured 2026-09-10: 6-9ms per `defprotocol`,
;; ~7ms per extended type; a startup of 0.04s became 0.25s, and every test
;; that builds a runtime per case slowed 8x). Each form here is exactly what
;; its macro would have produced; if the macros change shape, change these to
;; match. `-lookup`'s second arglist is kept as written above it in history.
(def ICounted (protocol* ICounted [{:name "-count" :min-arity 1 :variadic false}] false))
(def ^{:arglists '([coll])} -count (protocol-fn ICounted "-count"))
(def ILookup (protocol* ILookup [{:name "-lookup" :min-arity 2 :variadic false}] false))
(def ^{:arglists '([coll k] [-lookup [coll k not-found]])} -lookup (protocol-fn ILookup "-lookup"))
(def ISeqable (protocol* ISeqable [{:name "-seq" :min-arity 1 :variadic false}] false))
(def ^{:arglists '([coll])} -seq (protocol-fn ISeqable "-seq"))
(extend 'List ICounted {:-count (fn ([c] (count c)))})
(extend 'Vector ICounted {:-count (fn ([c] (count c)))})
(extend 'Map ICounted {:-count (fn ([c] (count c)))})
(extend 'Set ICounted {:-count (fn ([c] (count c)))})
(extend 'String ICounted {:-count (fn ([c] (count c)))})
(extend 'List ISeqable {:-seq (fn ([c] (seq c)))})
(extend 'Vector ISeqable {:-seq (fn ([c] (seq c)))})
(extend 'Map ISeqable {:-seq (fn ([c] (seq c)))})
(extend 'Set ISeqable {:-seq (fn ([c] (seq c)))})
;; ── Dynamic variables ──────────────────────────────────────────────────────
(def ^:dynamic *ns* nil)
(def ^:dynamic *out* nil)
(def ^:dynamic *err* nil)
(def ^:dynamic *assert* true)
(def ^:dynamic *print-dup* false)
(def ^:dynamic *print-readably* true)
(def ^:dynamic *print-length* nil)
(def ^:dynamic *print-level* nil)
(def ^:dynamic *1 nil)
(def ^:dynamic *2 nil)
(def ^:dynamic *3 nil)
(def ^:dynamic *e nil)
(defmacro with-bindings [binding-map & body]
`(with-bindings* ~binding-map (fn [] ~@body)))
(defmacro with-open
"bindings => [name init ...]
Evaluates body in a try expression with names bound to the values
of the inits, and a finally clause that calls (close name) on each
name in reverse order."
[bindings & body]
(assert (vector? bindings) "with-open requires a vector for its bindings")
(assert (even? (count bindings)) "with-open requires an even number of forms in binding vector")
(if (= (count bindings) 0)
`(do ~@body)
(let [name (first bindings)
init (second bindings)
rest-bindings (vec (drop 2 bindings))]
`(let [~name ~init]
(try
(with-open ~rest-bindings ~@body)
(finally
(close ~name)))))))
(defn max-key
"Returns the x for which (k x), a number, is greatest.
If there are multiple such xs, the last one is returned."
([k x] x)
([k x y] (if (> (k x) (k y)) x y))
([k x y & more]
(let [kx (k x) ky (k y)
[v kv] (if (> kx ky) [x kx] [y ky])]
(loop [v v kv kv more more]
(if more
(let [w (first more)
kw (k w)]
(if (>= kw kv)
(recur w kw (next more))
(recur v kv (next more))))
v)))))
(defn min-key
"Returns the x for which (k x), a number, is least.
If there are multiple such xs, the last one is returned."
([k x] x)
([k x y] (if (< (k x) (k y)) x y))
([k x y & more]
(let [kx (k x) ky (k y)
[v kv] (if (< kx ky) [x kx] [y ky])]
(loop [v v kv kv more more]
(if more
(let [w (first more)
kw (k w)]
(if (<= kw kv)
(recur w kw (next more))
(recur v kv (next more))))
v)))))
(defmacro comment
[& _]
nil)
(defmacro prn-str
[& body]
(list 'str (cons 'pr-str body) \newline))
; (try
; (do body)
; (finally (pop-precision!)))
(defmacro with-precision
[precision & body]
(if (and (= :rounding (first body))
(symbol? (second body)))
(list 'do (list 'push-precision! precision (list 'quote (second body)))
(list 'try
(cons 'do (drop 2 body))
(list 'finally (list 'pop-precision!))))
(list 'do (list 'push-precision! precision)
(list 'try
(cons 'do body)
(list 'finally (list 'pop-precision!))))))
(defn simple-ident?
"Returns true if x is a symbol or keyword without a namespace."
[v]
(and (or (keyword? v) (symbol? v)) (nil? (namespace v))))
(defn qualified-ident?
"Returns true if x is a symbol or keyword with a namespace."
[v]
(and (or (keyword? v) (symbol? v)) (not (nil? (namespace v)))))
(defn key
"Returns the key of a map entry."
[x]
(if (map-entry? x)
(first x)
(throw (ex-info "not a map entry" {}))))
(defn val
"Returns the value of a map entry."
[x]
(if (map-entry? x)
(second x)
(throw (ex-info "not a map entry" {}))))
(defn inc'
"Returns a number one greater than x, promoting to BigInt on overflow."
[x]
(+' x 1))
(defn dec'
"Returns a number one less than x, promoting to BigInt on overflow."
[x]
(+' x -1))
(defn ident?
"Returns true if x is a symbol or keyword."
[x] (or (symbol? x) (keyword? x)))
(defn rand-nth
"Return a random element of coll."
[coll]
(let [n (rand-int (count coll))]
(nth coll n)))
(defmacro when-first
"bindings => x xs. Roughly the same as (when (seq xs) (let [x (first
xs)] body)) but xs is evaluated only once."
[bindings & body]
(let [x (first bindings)
xs (second bindings)]
(list 'when-let [(first bindings) (list 'seq (second bindings))]
(list* 'let [(first bindings) (list 'first (first bindings))]
body))))
(defmacro bound-fn
"Returns a function defined by the given fntail, which will preserve the
current values of all thread-local bindings when called."
[& fntail]
(list 'bound-fn* (cons 'fn fntail)))
(defmacro cond->
"Takes an expression and a set of test/form pairs. Threads expr (via ->)
through each form for which the corresponding test expression is
logical true."
[expr & clauses]
(let [g (gensym)
steps (map (fn [[test step]] (list (quote if) test (list (quote ->) g step) g))
(partition 2 clauses))]
(list (quote let) (into [g expr] (interleave (repeat g) (butlast steps)))
(if (empty? steps) g (last steps)))))
(defmacro cond->>
"Takes an expression and a set of test/form pairs. Threads expr (via ->>)
through each form for which the corresponding test expression is
logical true."
[expr & clauses]
(let [g (gensym)
steps (map (fn [[test step]] (list (quote if) test (list (quote ->>) g step) g))
(partition 2 clauses))]
(list (quote let) (into [g expr] (interleave (repeat g) (butlast steps)))
(if (empty? steps)
g
(last steps)))))
(defmacro some->
"Threads expr through the forms (via ->), stopping and returning nil as
soon as a form returns nil."
[expr & forms]
(let [g (gensym)
steps (map (fn [step] (list (quote if) (list (quote nil?) g) nil (list (quote ->) g step)))
forms)]
(list (quote let) (into [g expr] (interleave (repeat g) (butlast steps)))
(if (empty? steps) g (last steps)))))
(defmacro some->>
"Threads expr through the forms (via ->>), stopping and returning nil as
soon as a form returns nil."
[expr & forms]
(let [g (gensym)
steps (map (fn [step] (list (quote if) (list (quote nil?) g) nil (list (quote ->>) g step)))
forms)]
(list (quote let) (into [g expr] (interleave (repeat g) (butlast steps)))
(if (empty? steps) g (last steps)))))
(defn re-seq
"Returns a lazy sequence of successive matches of pattern in string."
[re s]
(let [matcher (re-matcher re s)]
(seq (take-while identity (repeatedly #(re-find matcher))))))
(defmacro doc
"Returns the docstring of the given symbol (a var, macro, or special
form), or nil if it has none or doesn't resolve. See also `doc-data`,
which returns the docstring alongside the arglists."
[sym]
`(try
(:doc (doc-data (var ~sym)))
(catch Exception e# nil)))
;; ── Ad-hoc hierarchies ───────────────────────────────────────────────────────
;; A hierarchy is the value {:parents {} :descendants {} :ancestors {}}.
;; The 3-arity fns below are pure functions of such a value; the 2-arity fns
;; read and update the one held in `global-hierarchy`.
(defn- named?
"True if x is a keyword or a symbol."
[x]
(or (keyword? x) (symbol? x)))
(defn- hierarchy?
"True if x is a map carrying the :parents, :descendants and :ancestors
relation maps."
[x]
(and (map? x)
(map? (:parents x))
(map? (:descendants x))
(map? (:ancestors x))))
(defn- check-hierarchy!
"Throws unless h is a hierarchy."
[h]
(when-not (hierarchy? h)
(throw (ex-info (str "Not a hierarchy: " (pr-str h)) {:hierarchy h}))))
(defn- check-tag!
"Throws unless tag is a keyword or symbol, optionally requiring a namespace."
[tag namespaced?]
(when-not (named? tag)
(throw (ex-info (str "Not a valid tag: " (pr-str tag)) {:tag tag})))
(when (and namespaced? (nil? (namespace tag)))
(throw (ex-info (str "Tag must be namespaced: " (pr-str tag)) {:tag tag}))))
(def ^:private global-hierarchy
"The hierarchy `derive`, `isa?`, `parents`, `ancestors` and `descendants`
use when called without an explicit hierarchy."
(make-hierarchy))
(defn- extend-relation
"Adds target (and everything targets relates it to) to the entry of source
and of every source it already relates to."
[m source sources target targets]
(reduce (fn [ret k]
(assoc ret k (reduce conj
(get targets k #{})
(cons target (get targets target)))))
m
(cons source (get sources source))))
(defn derive
"Establishes a parent/child relationship between parent and tag. The
two-argument form requires namespaced keywords or symbols. With an explicit
hierarchy h, unqualified tags are accepted and the modified hierarchy is
returned; without one, alters the global hierarchy and returns nil."
([tag parent]
(check-tag! tag true)
(check-tag! parent true)
(alter-var-root (var global-hierarchy)
(fn [h] (derive h tag parent)))
nil)
([h tag parent]
(check-hierarchy! h)
(check-tag! tag false)
(check-tag! parent false)
(when (= tag parent)
(throw (ex-info (str "Cyclic derivation: " (pr-str tag) " has itself as ancestor")
{:tag tag :parent parent})))
(let [tp (:parents h)
td (:descendants h)
ta (:ancestors h)]
(if (contains? (get tp tag) parent)
h
(do
(when (contains? (get ta parent) tag)
(throw (ex-info (str "Cyclic derivation: " (pr-str parent)
" has " (pr-str tag) " as ancestor")
{:tag tag :parent parent})))
{:parents (assoc tp tag (conj (get tp tag #{}) parent))
:ancestors (extend-relation ta tag td parent ta)
:descendants (extend-relation td parent ta tag td)})))))
(defn underive
"Removes a parent/child relationship between parent and tag. With a
hierarchy h, returns the modified hierarchy; without one, alters the global
hierarchy and returns nil."
([tag parent]
(alter-var-root (var global-hierarchy)
(fn [h] (underive h tag parent)))
nil)
([h tag parent]
(check-hierarchy! h)
(let [parent-map (:parents h)
childs-parents (if (get parent-map tag)
(disj (get parent-map tag) parent)
#{})
new-parents (if (not-empty childs-parents)
(assoc parent-map tag childs-parents)
(dissoc parent-map tag))
deriv-seq (flatten (map (fn [e] (cons (first e) (interpose (first e) (second e))))
(seq new-parents)))]
(if (contains? (get parent-map tag) parent)
(reduce (fn [ret pair] (derive ret (first pair) (second pair)))
(make-hierarchy)
(partition 2 deriv-seq))
h))))
(defn isa?
"True if child is the same as parent, or a descendant of it in the
hierarchy. Vectors are compared element-wise."
([child parent] (isa? global-hierarchy child parent))
([h child parent]
(boolean
(or (= child parent)
(contains? (get (:ancestors h) child) parent)
(and (vector? parent)
(vector? child)
(= (count parent) (count child))
(loop [ret true i 0]
(if (or (not ret) (= i (count parent)))
ret
(recur (isa? h (nth child i) (nth parent i)) (inc i)))))))))
(defn parents
"Returns the immediate parents of tag, or nil if it has none."
([tag] (parents global-hierarchy tag))
([h tag] (not-empty (get (:parents h) tag))))
(defn ancestors
"Returns the immediate and indirect parents of tag, or nil if it has none."
([tag] (ancestors global-hierarchy tag))
([h tag] (not-empty (get (:ancestors h) tag))))
(defn descendants
"Returns the immediate and indirect children of tag, or nil if it has none."
([tag] (descendants global-hierarchy tag))
([h tag] (not-empty (get (:descendants h) tag))))
;; ── datatypes: deftype as a macro over the deftype* primitive ────────────────
;; The irreducible `deftype*` special form mints the type tag and registers the
;; method impls (with fields in scope, mutable fields on live cells). The sugar —
;; the positional `->T` constructor and the `T` type symbol — is a Clojure macro,
;; so `deftype` is a particular case of an ordinary macro rather than a bespoke
;; Rust form. Field mutability is read from each field's metadata (survives
;; macroexpansion), splitting the constructor between immutable and mutable maps.
(defmacro deftype [tsym fields & impls]
(let [tname (str tsym)
ctor (symbol (str "->" tsym))
mut? (fn [f] (let [m (meta f)]
(boolean (or (:unsynchronized-mutable m)
(:volatile-mutable m)))))
bare (fn [f] (symbol (name f)))
kw (fn [f] (keyword (name f)))
plain (mapv bare fields)
imm (remove mut? fields)
mut (filter mut? fields)
immm (zipmap (map kw imm) (map bare imm))
mutm (zipmap (map kw mut) (map bare mut))]
`(do
(deftype* ~tsym ~fields ~@impls)
(defn ~ctor [~@plain]
~(if (seq mut)
`(make-type-instance-mut ~tname ~immm ~mutm)
`(make-type-instance ~tname ~immm)))
(def ~tsym (quote ~tsym))
~tsym)))
;; defrecord: like deftype but fields are always immutable and it also gets the
;; map constructor `map->T`. Same macro-over-deftype* shape.
(defmacro defrecord [tsym fields & impls]
(let [tname (str tsym)
pos (symbol (str "->" tsym))
mapc (symbol (str "map->" tsym))
bare (fn [f] (symbol (name f)))
kw (fn [f] (keyword (name f)))
plain (mapv bare fields)
fmap (zipmap (map kw fields) (map bare fields))]
`(do
(deftype* ~tsym ~plain ~@impls)
(defn ~pos [~@plain] (make-type-instance ~tname ~fmap))
(defn ~mapc [m#] (make-type-instance ~tname m#))
(def ~tsym (quote ~tsym))
~tsym)))
;; reify: an anonymous, field-less instance whose methods close over the
;; surrounding lexical scope. One gensym'd tag per reify FORM (Clojure semantics:
;; one anonymous type per form, a fresh instance each time the form evaluates).
;; The impl fns capture locals because deftype* registers them at the call site.
(defmacro reify [& impls]
`(make-type-instance (deftype* ~(gensym "reify__") [] ~@impls) {}))