1.1.x: Kondo hooks

.github/workflows/build.yml

@@ -42,6 +42,8 @@ jobs:
         uses: DeLaGuardo/setup-clojure@master
         with:
           lein: latest
+      - name: Check kondo hooks
+        run: cd examples/clj-kondo-hooks && ./script/test
       - name: Run tests
         run: lein do clean, all midje, all check
   deploy:

README.md

@@ -101,6 +101,25 @@ lein new compojure-api my-api +clojure-test
 
 ## License
 
+Copied code from tools.macro has license:
+
+```
+Copyright (c) Rich Hickey. All rights reserved.
+The use and distribution terms for this software are covered by the Eclipse Public License 1.0 (https://opensource.org/license/epl-1-0/)
+which can be found in the file epl-v10.html at the root of this distribution. By using this software in any fashion, you are agreeing to
+be bound bythe terms of this license. You must not remove this notice, or any other, from this software.
+```
+
+Copied code from compojure has license:
+
+```
+Copyright © 2024 James Reeves
+
+Distributed under the Eclipse Public License, the same as Clojure.
+```
+
+All other code:
+
 Copyright © 2014-2016 [Metosin Oy](https://www.metosin.fi)
 
 Distributed under the Eclipse Public License, the same as Clojure.

deps.edn

@@ -0,0 +1,11 @@
+{:paths ["src" "resources"]
+ :deps {prismatic/plumbing {:mvn/version "0.6.0"}
+        cheshire/cheshire {:mvn/version "5.13.0"}
+        compojure/compojure {:mvn/version "1.6.1"}
+        prismatic/schema {:mvn/version "1.1.12"}
+        org.tobereplaced/lettercase {:mvn/version "1.0.0"}
+        frankiesardo/linked {:mvn/version "1.3.0"}
+        ring-middleware-format/ring-middleware-format {:mvn/version "0.7.4"}
+        metosin/ring-http-response {:mvn/version "0.9.1"}
+        metosin/ring-swagger {:mvn/version "1.0.0"}
+        metosin/ring-swagger-ui {:mvn/version "2.2.10"}}}

dev/compojure_api_kondo_hooks/compojure/core.clj

@@ -0,0 +1,60 @@
+;; Copyright © 2024 James Reeves
+;; 
+;; Distributed under the Eclipse Public License, the same as Clojure.
+(ns compojure-api-kondo-hooks.compojure.core)
+
+(defn- and-binding [req binds]
+  `(dissoc (:params ~req) ~@(map keyword (keys binds)) ~@(map str (keys binds))))
+
+(defn- symbol-binding [req sym]
+  `(get-in ~req [:params ~(keyword sym)] (get-in ~req [:params ~(str sym)])))
+
+(defn- application-binding [req sym func]
+  `(~func ~(symbol-binding req sym)))
+
+(defn- vector-bindings [args req]
+  (loop [args args, binds {}]
+    (if (seq args)
+      (let [[x y z] args]
+        (cond
+          (= '& x)
+          (recur (nnext args) (assoc binds y (and-binding req binds)))
+          (= :as x)
+          (recur (nnext args) (assoc binds y req))
+          (and (symbol? x) (= :<< y) (nnext args))
+          (recur (drop 3 args) (assoc binds x (application-binding req x z)))
+          (symbol? x)
+          (recur (next args) (assoc binds x (symbol-binding req x)))
+          :else
+          (throw (Exception. (str "Unexpected binding: " x)))))
+      (mapcat identity binds))))
+
+(defn- warn-on-*-bindings! [bindings]
+  (when (and (vector? bindings) (contains? (set bindings) '*))
+    (binding [*out* *err*]
+      (println "WARNING: * should not be used as a route binding."))))
+
+(defn- application-symbols [args]
+  (loop [args args, syms '()]
+    (if (seq args)
+      (let [[x y] args]
+        (if (and (symbol? x) (= :<< y))
+          (recur (drop 3 args) (conj syms x))
+          (recur (next args) syms)))
+      (seq syms))))
+
+(defmacro ^:no-doc let-request [[bindings request] & body]
+  (if (vector? bindings)
+    `(let [~@(vector-bindings bindings request)]
+       ~(if-let [syms (application-symbols bindings)]
+          `(if (and ~@(for [s syms] `(not (nil? ~s)))) (do ~@body))
+          `(do ~@body)))
+    `(let [~bindings ~request] ~@body)))
+
+(defn compile-route
+  "Compile a route in the form `(method path bindings & body)` into a function.
+  Used to create custom route macros."
+  [method path bindings body]
+  (let [greq (gensym "greq")]
+    `(fn [~greq]
+       ~(macroexpand-1 `(let-request [~bindings ~greq] ~@body)))))

dev/compojure_api_kondo_hooks/plumbing/core.clj

@@ -0,0 +1,42 @@
+(ns compojure-api-kondo-hooks.plumbing.core
+  "Utility belt for Clojure in the wild"
+  (:refer-clojure :exclude [update])
+  (:require
+   [compojure-api-kondo-hooks.schema.macros :as schema-macros]
+   [compojure-api-kondo-hooks.plumbing.fnk.impl :as fnk-impl]))
+
+(defmacro letk
+  "Keyword let.  Accepts an interleaved sequence of binding forms and map forms like:
+   (letk [[a {b 2} [:f g h] c d {e 4} :as m & more] a-map ...] & body)
+   a, c, d, and f are required keywords, and letk will barf if not in a-map.
+   b and e are optional, and will be bound to default values if not present.
+   g and h are required keys in the map found under :f.
+   m will be bound to the entire map (a-map).
+   more will be bound to all the unbound keys (ie (dissoc a-map :a :b :c :d :e)).
+   :as and & are both optional, but must be at the end in the specified order if present.
+   The same symbol cannot be bound multiple times within the same destructing level.
+
+   Optional values can reference symbols bound earlier within the same binding, i.e.,
+   (= [2 2] (let [a 1] (letk [[a {b a}] {:a 2}] [a b]))) but
+   (= [2 1] (let [a 1] (letk [[{b a} a] {:a 2}] [a b])))
+
+   If present, :as and :& symbols are bound before other symbols within the binding.
+
+   Namespaced keys are supported by specifying fully-qualified key in binding form. The bound
+   symbol uses the _name_ portion of the namespaced key, i.e,
+   (= 1 (letk [[a/b] {:a/b 1}] b)).
+
+   Map destructuring bindings can be mixed with ordinary symbol bindings."
+  [bindings & body]
+  (reduce
+   (fn [cur-body-form [bind-form value-form]]
+     (if (symbol? bind-form)
+       `(let [~bind-form ~value-form] ~cur-body-form)
+       (let [{:keys [map-sym body-form]} (fnk-impl/letk-input-schema-and-body-form
+                                          &env
+                                          bind-form ;(fnk-impl/ensure-schema-metadata &env bind-form)
+                                          []
+                                          cur-body-form)]
+         `(let [~map-sym ~value-form] ~body-form))))
+   `(do ~@body)
+   (reverse (partition 2 bindings))))

dev/compojure_api_kondo_hooks/plumbing/fnk/impl.clj

@@ -0,0 +1,116 @@
+(ns compojure-api-kondo-hooks.plumbing.fnk.impl
+  (:require
+   [clojure.set :as set]
+   [schema.core :as-alias s]
+   [compojure-api-kondo-hooks.schema.macros :as schema-macros]))
+
+;;;;; Helpers
+
+(defn name-sym
+  "Returns symbol of x's name.
+   Converts a keyword/string to symbol, or removes namespace (if any) of symbol"
+  [x]
+  (with-meta (symbol (name x)) (meta x)))
+
+;;; Parsing new fnk binding style
+
+(declare letk-input-schema-and-body-form)
+
+(defn- process-schematized-map
+  "Take an optional binding map like {a 2} or {a :- Number 2} and convert the schema
+   information to canonical metadata, if present."
+  [env binding]
+  (case (count binding)
+    1 (let [[sym v] (first binding)]
+        {sym v})
+
+    2 (let [[[[sym _]] [[schema v]]] ((juxt filter remove) #(= (val %) :-) binding)]
+        {sym v})))
+
+;; TODO: unify this with positional version.
+(defn letk-arg-bind-sym-and-body-form
+  "Given a single element of a single letk binding form and a current body form, return
+   a map {:schema-entry :body-form} where schema-entry is a tuple
+   [bound-key schema external-schema?], and body-form wraps body with destructuring
+   for this binding as necessary."
+  [env map-sym binding key-path body-form]
+  (cond (symbol? binding)
+        {:schema-entry []
+         :body-form `(let [~(name-sym binding) (get ~map-sym ~(keyword binding) ~key-path)]
+                       ~body-form)}
+
+        (map? binding)
+        (let [schema-fixed-binding (process-schematized-map env binding)
+              [bound-sym opt-val-expr] (first schema-fixed-binding)
+              bound-key (keyword bound-sym)]
+          {:schema-entry []
+           :body-form `(let [~(name-sym bound-sym) (get ~map-sym ~bound-key ~opt-val-expr)]
+                         ~body-form)})
+
+        (vector? binding)
+        (let [[bound-key & more] binding
+              {inner-input-schema :input-schema
+               inner-external-input-schema :external-input-schema
+               inner-map-sym :map-sym
+               inner-body-form :body-form} (letk-input-schema-and-body-form
+                                            env
+                                            (with-meta (vec more) (meta binding))
+                                            (conj key-path bound-key)
+                                            body-form)]
+          {:schema-entry []
+           :body-form `(let [~inner-map-sym (get ~map-sym ~bound-key ~key-path)]
+                         ~inner-body-form)})
+
+        :else (throw (ex-info (format "bad binding: %s" binding) {}))))
+
+(defn- extract-special-args
+  "Extract trailing & sym and :as sym, possibly with schema metadata. Returns
+  [more-bindings special-args-map] where special-args-map is a map from each
+  special symbol found to the symbol that was found."
+  [env special-arg-signifier-set binding-form]
+  {:pre [(set? special-arg-signifier-set)]}
+  (let [[more-bindings special-bindings] (split-with (complement special-arg-signifier-set) binding-form)]
+    (loop [special-args-map {}
+           special-arg-set special-arg-signifier-set
+           [arg-signifier & other-bindings :as special-bindings] special-bindings]
+      (if-not (seq special-bindings)
+        [more-bindings special-args-map]
+        (do
+          (let [[sym remaining-bindings] (schema-macros/extract-arrow-schematized-element env other-bindings)]
+            (recur (assoc special-args-map arg-signifier sym)
+                   (disj special-arg-set arg-signifier)
+                   remaining-bindings)))))))
+
+(defn letk-input-schema-and-body-form
+  "Given a single letk binding form, value form, key path, and body
+   form, return a map {:input-schema :external-input-schema :map-sym :body-form}
+   where input-schema is the schema imposed by binding-form, external-input-schema
+   is like input-schema but includes user overrides for binding vectors,
+   map-sym is the symbol which it expects the bound value to be bound to,
+   and body-form wraps body in the bindings from binding-form from map-sym."
+  [env binding-form key-path body-form]
+  (let [[bindings {more-sym '& as-sym :as}] (extract-special-args env #{'& :as} binding-form)
+        as-sym (or as-sym (gensym "map"))
+        [input-schema-elts
+         external-input-schema-elts
+         bound-body-form] (reduce
+                           (fn [[input-schema-elts external-input-schema-elts cur-body] binding]
+                             (let [{:keys [schema-entry body-form]}
+                                   (letk-arg-bind-sym-and-body-form
+                                    env as-sym binding key-path cur-body)
+                                   [bound-key input-schema external-input-schema] schema-entry]
+                               [(conj input-schema-elts [bound-key input-schema])
+                                (conj external-input-schema-elts
+                                      [bound-key (or external-input-schema input-schema)])
+                                body-form]))
+                           [[] [] body-form]
+                           (reverse
+                            (schema-macros/process-arrow-schematized-args
+                             env bindings)))
+        explicit-schema-keys []
+        final-body-form (if more-sym
+                          `(let [~more-sym (dissoc ~as-sym ~@explicit-schema-keys)]
+                             ~bound-body-form)
+                          bound-body-form)]
+    {:map-sym as-sym
+     :body-form final-body-form}))

dev/compojure_api_kondo_hooks/plumbing/fnk/schema.clj

@@ -0,0 +1,16 @@
+
+(s/defn unwrap-schema-form-key :- (s/maybe (s/pair s/Keyword "k" s/Bool "optional?"))
+  "Given a possibly-unevaluated schema map key form, unpack an explicit keyword
+   and optional? flag, or return nil for a non-explicit key"
+  [k]
+  (cond (s/specific-key? k)
+        [(s/explicit-schema-key k) (s/required-key? k)]
+
+        ;; Deal with `(s/optional-key k) form from impl
+        (and (sequential? k) (not (vector? k)) (= (count k) 2)
+             (= (first k) 'schema.core/optional-key))
+        [(second k) false]
+
+        ;; Deal with `(with-meta ...) form from impl
+        (and (sequential? k) (not (vector? k)) (= (first k) `with-meta))
+        (unwrap-schema-form-key (second k))))

dev/compojure_api_kondo_hooks/schema/macros.clj

@@ -0,0 +1,24 @@
+(ns compojure-api-kondo-hooks.schema.macros)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Helpers for processing and normalizing element/argument schemas in s/defrecord and s/(de)fn
+
+(defn extract-arrow-schematized-element
+  "Take a nonempty seq, which may start like [a ...] or [a :- schema ...], and return
+   a list of [first-element-with-schema-attached rest-elements]"
+  [env s]
+  (assert (seq s))
+  (let [[f & more] s]
+    (if (= :- (first more))
+      [f (drop 2 more)]
+      [f more])))
+
+(defn process-arrow-schematized-args
+  "Take an arg vector, in which each argument is followed by an optional :- schema,
+   and transform into an ordinary arg vector where the schemas are metadata on the args."
+  [env args]
+  (loop [in args out []]
+    (if (empty? in)
+      out
+      (let [[arg more] (extract-arrow-schematized-element env in)]
+        (recur more (conj out arg))))))