Merge pull request #1027 from frenchy64/flat-arrow

WIP: `:->`

src/malli/clj_kondo.cljc

@@ -8,7 +8,7 @@
 
 (defmulti accept (fn [name _schema _children _options] name) :default ::default)
 
-(defmethod accept ::default [_ _ _ _] :any)
+(defmethod accept ::default [_ schema _ _] (if (m/-function-schema? schema) :fn :any))
 (defmethod accept 'any? [_ _ _ _] :any)
 (defmethod accept 'some? [_ _ _ _] :any) ;;??
 (defmethod accept 'number? [_ _ _ _] :number)
@@ -105,8 +105,6 @@
 (defmethod accept :re [_ _ _ _] :string)
 (defmethod accept :fn [_ _ _ _] :any)
 (defmethod accept :ref [_ _ _ _] :any) ;;??
-(defmethod accept :=> [_ _ _ _] :fn)
-(defmethod accept :function [_ _ _ _] :fn)
 (defmethod accept :schema [_ schema _ options] (transform (m/deref schema) options))
 
 (defmethod accept ::m/schema [_ schema _ options] (transform (m/deref schema) options))
@@ -175,9 +173,9 @@
         (spit cfg-file (with-out-str (fipp/pprint config {:width 120})))
         config))))
 
-(defn from [{:keys [schema ns name]}]
+(defn from [{?schema :schema :keys [ns name]}]
   (let [ns-name (-> ns str symbol)
-        schema (if (= :function (m/type schema)) schema (m/into-schema :function nil [schema] (m/options schema)))]
+        schema (m/function-schema ?schema)]
     (reduce
      (fn [acc schema]
        (let [{:keys [input output arity min]} (m/-function-info schema)
@@ -189,7 +187,8 @@
                             :args args
                             :ret ret}
                      (= arity :varargs) (assoc :min-arity min)))))
-     [] (m/children schema))))
+     [] (or (seq (m/-function-schema-arities schema))
+            (m/-fail! ::from-requires-function-schema {:schema schema})))))
 
 (defn collect
   ([] (collect nil))

src/malli/core.cljc

@@ -14,7 +14,7 @@
 
 (declare schema schema? into-schema into-schema? type eval default-registry
          -simple-schema -val-schema -ref-schema -schema-schema -registry
-         parser unparser ast from-ast)
+         parser unparser ast from-ast -instrument)
 
 ;;
 ;; protocols and records
@@ -86,6 +86,12 @@
   (-regex-transformer [this transformer method options] "returns the raw internal regex transformer implementation")
   (-regex-min-max [this nested?] "returns size of the sequence as {:min min :max max}. nil max means unbounded. nested? is true when this schema is nested inside an outer regex schema."))
 
+(defprotocol FunctionSchema
+  (-function-schema? [this])
+  (-function-schema-arities [this])
+  (-function-info [this])
+  (-instrument-f [schema props f options]))
+
 (defn -ref-schema? [x] (#?(:clj instance?, :cljs implements?) malli.core.RefSchema x))
 (defn -entry-parser? [x] (#?(:clj instance?, :cljs implements?) malli.core.EntryParser x))
 (defn -entry-schema? [x] (#?(:clj instance?, :cljs implements?) malli.core.EntrySchema x))
@@ -94,6 +100,12 @@
 (defn -transformer? [x] (#?(:clj instance?, :cljs implements?) malli.core.Transformer x))
 
 (extend-type #?(:clj Object, :cljs default)
+  FunctionSchema
+  (-function-schema? [_] false)
+  (-function-info [_])
+  (-function-schema-arities [_])
+  (-instrument-f [_ _ _ _])
+
   RegexSchema
   (-regex-op? [_] false)
 
@@ -202,17 +214,6 @@
   (let [value #?(:clj (AtomicReference. nil), :cljs (atom nil))]
     (fn [] #?(:clj (or (.get value) (do (.set value (f)) (.get value))), :cljs (or @value (reset! value (f)))))))
 
-(defn -function-info [schema]
-  (when (= (type schema) :=>)
-    (let [[input output guard] (-children schema)
-          {:keys [min max]} (-regex-min-max input false)]
-      (cond-> {:min min
-               :arity (if (= min max) min :varargs)
-               :input input
-               :output output}
-        guard (assoc :guard guard)
-        max (assoc :max max)))))
-
 (defn -group-by-arity! [infos]
   (let [aritys (atom #{})]
     (reduce
@@ -1806,6 +1807,36 @@
           (-children [_] children)
           (-parent [_] parent)
           (-form [_] @form)
+          FunctionSchema
+          (-function-schema? [_] true)
+          (-function-schema-arities [this] [this])
+          (-function-info [_]
+            (let [{:keys [min max]} (-regex-min-max input false)]
+              (cond-> {:min min
+                       :arity (if (= min max) min :varargs)
+                       :input input
+                       :output output}
+                guard (assoc :guard guard)
+                max (assoc :max max))))
+          (-instrument-f [schema {:keys [scope report gen] :as props} f _options]
+            (let [{:keys [min max input output guard]} (-function-info schema)
+                  [validate-input validate-output] (-vmap -validator [input output])
+                  validate-guard (or (some-> guard -validator) any?)
+                  [wrap-input wrap-output wrap-guard] (-vmap #(contains? scope %) [:input :output :guard])
+                  f (or (if gen (gen schema) f) (-fail! ::missing-function {:props props}))]
+              (fn [& args]
+                (let [args (vec args), arity (count args)]
+                  (when wrap-input
+                    (when-not (<= min arity (or max miu/+max-size+))
+                      (report ::invalid-arity {:arity arity, :arities #{{:min min :max max}}, :args args, :input input, :schema schema}))
+                    (when-not (validate-input args)
+                      (report ::invalid-input {:input input, :args args, :schema schema})))
+                  (let [value (apply f args)]
+                    (when (and wrap-output (not (validate-output value)))
+                      (report ::invalid-output {:output output, :value value, :args args, :schema schema}))
+                    (when (and wrap-guard (not (validate-guard [args value])))
+                      (report ::invalid-guard {:guard guard, :value value, :args args, :schema schema}))
+                    value)))))
           Cached
           (-cache [_] cache)
           LensSchema
@@ -1826,7 +1857,7 @@
             form (delay (-simple-form parent properties children -form options))
             cache (-create-cache options)
             ->checker (if function-checker #(function-checker % options) (constantly nil))]
-        (when-not (every? #(= :=> (type %)) children)
+        (when-not (every? (every-pred -function-schema? -function-info) children)
           (-fail! ::non-function-childs {:children children}))
         (-group-by-arity! (-vmap -function-info children))
         ^{:type ::schema}
@@ -1858,13 +1889,96 @@
           (-children [_] children)
           (-parent [_] parent)
           (-form [_] @form)
+          FunctionSchema
+          (-function-schema? [_] true)
+          (-function-schema-arities [_] children)
+          (-function-info [_])
+          (-instrument-f [this {:keys [_scope report] :as props} f options]
+            (let [arity->info (->> children
+                                   (map (fn [s] (assoc (-function-info s) :f (-instrument (assoc props :schema s) f options))))
+                                   (-group-by-arity!))
+                  arities (-> arity->info keys set)
+                  varargs-info (arity->info :varargs)]
+              (if (= 1 (count arities))
+                (-> arity->info first val :f)
+                (fn [& args]
+                  (let [arity (count args)
+                        {:keys [input] :as info} (arity->info arity)
+                        report-arity #(report ::invalid-arity {:arity arity, :arities arities, :args args, :input input, :schema this})]
+                    (cond
+                      info (apply (:f info) args)
+                      varargs-info (if (< arity (:min varargs-info)) (report-arity) (apply (:f varargs-info) args))
+                      :else (report-arity)))))))
           Cached
           (-cache [_] cache)
           LensSchema
           (-keep [_])
           (-get [_ key default] (get children key default))
           (-set [this key value] (-set-assoc-children this key value)))))))
 
+(defn -proxy-schema [{:keys [type min max childs type-properties fn]}]
+  ^{:type ::into-schema}
+  (reify IntoSchema
+    (-type [_] type)
+    (-type-properties [_] type-properties)
+    (-properties-schema [_ _])
+    (-children-schema [_ _])
+    (-into-schema [parent properties children options]
+      (-check-children! type properties children min max)
+      (let [[children forms schema] (fn properties (vec children) options)
+            form (delay (-create-form type properties forms options))
+            cache (-create-cache options)]
+        ^{:type ::schema}
+        (reify
+          Schema
+          (-validator [_] (-validator schema))
+          (-explainer [_ path] (-explainer schema path))
+          (-parser [_] (-parser schema))
+          (-unparser [_] (-unparser schema))
+          (-transformer [this transformer method options]
+            (-parent-children-transformer this [schema] transformer method options))
+          (-walk [this walker path options]
+            (let [children (if childs (subvec children 0 childs) children)]
+              (when (-accept walker this path options)
+                (-outer walker this path (-inner-indexed walker path children options) options))))
+          (-properties [_] properties)
+          (-options [_] options)
+          (-children [_] children)
+          (-parent [_] parent)
+          (-form [_] @form)
+          Cached
+          (-cache [_] cache)
+          LensSchema
+          (-keep [_])
+          (-get [_ key default] (get children key default))
+          (-set [_ key value] (into-schema type properties (assoc children key value)))
+          FunctionSchema
+          (-function-schema? [_] (-function-schema? schema))
+          (-function-info [_] (-function-info schema))
+          (-function-schema-arities [_] (-function-schema-arities schema))
+          (-instrument-f [_ props f options] (-instrument-f schema props f options))
+          RegexSchema
+          (-regex-op? [_] (-regex-op? schema))
+          (-regex-validator [_] (-regex-validator schema))
+          (-regex-explainer [_ path] (-regex-explainer schema path))
+          (-regex-unparser [_] (-regex-unparser schema))
+          (-regex-parser [_] (-regex-parser schema))
+          (-regex-transformer [_ transformer method options] (-regex-transformer schema transformer method options))
+          (-regex-min-max [_ nested?] (-regex-min-max schema nested?))
+          RefSchema
+          (-ref [_])
+          (-deref [_] schema))))))
+
+(defn -->-schema
+  "Experimental simple schema for :=> schema. AST and explain results subject to change."
+  [_]
+  (-proxy-schema {:type :->
+                  :fn (fn [{:keys [guard] :as p} c o]
+                        (let [c (mapv #(schema % o) c)
+                              cc (cond-> [(into [:cat] (pop c)) (peek c)]
+                                   guard (conj [:fn guard]))]
+                          [c (map -form c) (into-schema :=> (dissoc p :guard) cc o)]))}))
+
 (defn- regex-validator [schema] (re/validator (-regex-validator schema)))
 
 (defn- regex-explainer [schema path] (re/explainer schema path (-regex-explainer schema path)))
@@ -2510,6 +2624,7 @@
    :fn (-fn-schema)
    :ref (-ref-schema)
    :=> (-=>-schema)
+   ;:-> (-->-schema nil)
    :function (-function-schema nil)
    :schema (-schema-schema nil)
    ::schema (-schema-schema {:raw true})})
@@ -2553,8 +2668,8 @@
 (defn function-schema
   ([?schema] (function-schema ?schema nil))
   ([?schema options]
-   (let [s (schema ?schema options), t (type s)]
-     (if (#{:=> :function} t) s (-fail! ::invalid-=>schema {:type t, :schema s})))))
+   (let [s (schema ?schema options)]
+     (if (-function-schema? s) s (-fail! ::invalid-=>schema {:type (type s), :schema s})))))
 
 ;; for cljs we cannot invoke `function-schema` at macroexpansion-time
 ;; - `?schema` could contain cljs vars that will only resolve at runtime.
@@ -2601,38 +2716,10 @@
    (-instrument props nil nil))
   ([props f]
    (-instrument props f nil))
-  ([{:keys [scope report gen] :or {scope #{:input :output :guard}, report -fail!} :as props} f options]
-   (let [schema (-> props :schema (schema options))]
-     (case (type schema)
-       :=> (let [{:keys [min max input output guard]} (-function-info schema)
-                 [validate-input validate-output validate-guard] (-vmap validator [input output (or guard :any)])
-                 [wrap-input wrap-output wrap-guard] (-vmap #(contains? scope %) [:input :output :guard])
-                 f (or (if gen (gen schema) f) (-fail! ::missing-function {:props props}))]
-             (fn [& args]
-               (let [args (vec args), arity (count args)]
-                 (when wrap-input
-                   (when-not (<= min arity (or max miu/+max-size+))
-                     (report ::invalid-arity {:arity arity, :arities #{{:min min :max max}}, :args args, :input input, :schema schema}))
-                   (when-not (validate-input args)
-                     (report ::invalid-input {:input input, :args args, :schema schema})))
-                 (let [value (apply f args)]
-                   (when (and wrap-output (not (validate-output value)))
-                     (report ::invalid-output {:output output, :value value, :args args, :schema schema}))
-                   (when (and wrap-guard (not (validate-guard [args value])))
-                     (report ::invalid-guard {:guard guard, :value value, :args args, :schema schema}))
-                   value))))
-       :function (let [arity->info (->> (children schema)
-                                        (map (fn [s] (assoc (-function-info s) :f (-instrument (assoc props :schema s) f options))))
-                                        (-group-by-arity!))
-                       arities (-> arity->info keys set)
-                       varargs-info (arity->info :varargs)]
-                   (if (= 1 (count arities))
-                     (-> arity->info first val :f)
-                     (fn [& args]
-                       (let [arity (count args)
-                             {:keys [input] :as info} (arity->info arity)
-                             report-arity #(report ::invalid-arity {:arity arity, :arities arities, :args args, :input input, :schema schema})]
-                         (cond
-                           info (apply (:f info) args)
-                           varargs-info (if (< arity (:min varargs-info)) (report-arity) (apply (:f varargs-info) args))
-                           :else (report-arity))))))))))
+  ([props f options]
+   (let [props (-> props
+                   (update :scope #(or % #{:input :output :guard}))
+                   (update :report #(or % -fail!)))
+         s (-> props :schema (schema options))]
+     (or (-instrument-f s props f options)
+         (-fail! ::instrument-requires-function-schema {:schema s})))))

src/malli/experimental/describe.cljc

@@ -191,9 +191,11 @@
 (defmethod accept :qualified-symbol [_ _ _ _] "qualified symbol")
 (defmethod accept :uuid [_ _ _ _] "uuid")
 
-(defmethod accept :=> [_ s _ _]
+(defn -accept-=> [s]
   (let [{:keys [input output]} (m/-function-info s)]
     (str "function that takes input: [" (describe input) "] and returns " (describe output))))
+(defmethod accept :=> [_ s _ _] (-accept-=> s))
+(defmethod accept :-> [_ s _ _] (-accept-=> s))
 
 (defmethod accept :function [_ _ _children _] "function")
 (defmethod accept :fn [_ _ _ _] "function")

src/malli/generator.cljc

@@ -327,7 +327,7 @@
     (gen/return (m/-instrument {:schema schema} (fn [& _] (generate output-generator options))))))
 
 (defn -function-gen [schema options]
-  (gen/return (m/-instrument {:schema schema, :gen #(generate % options)} options)))
+  (gen/return (m/-instrument {:schema schema, :gen #(generate % options)} nil options)))
 
 (defn -regex-generator [schema options]
   (if (m/-regex-op? schema)
@@ -479,6 +479,7 @@
 (defmethod -schema-generator :uuid [_ _] gen/uuid)
 
 (defmethod -schema-generator :=> [schema options] (-=>-gen schema options))
+(defmethod -schema-generator :-> [schema options] (-=>-gen schema options))
 (defmethod -schema-generator :function [schema options] (-function-gen schema options))
 (defmethod -schema-generator 'ifn? [_ _] gen/keyword)
 (defmethod -schema-generator :ref [schema options] (-ref-gen schema options))
@@ -603,11 +604,12 @@
                              explain-output (assoc ::m/explain-output explain-output)
                              explain-guard (assoc ::m/explain-guard explain-guard)
                              (ex-message result) (-> (update :result ex-message) (dissoc :result-data)))))))))]
-     (condp = (m/type schema)
-       :=> (check schema)
-       :function (let [checkers (map #(function-checker % options) (m/-children schema))]
-                   (fn [x] (->> checkers (keep #(% x)) (seq))))
-       (m/-fail! ::invalid-function-schema {:type (m/-type schema)})))))
+     (if (m/-function-info schema)
+       (check schema)
+       (if (m/-function-schema? schema)
+         (let [checkers (map #(function-checker % options) (m/-function-schema-arities schema))]
+           (fn [x] (->> checkers (keep #(% x)) (seq))))
+         (m/-fail! ::invalid-function-schema {:type (m/-type schema)}))))))
 
 (defn check
   ([?schema f] (check ?schema f nil))

src/malli/util.cljc

@@ -382,45 +382,7 @@
      (clojure.core/update children 0 #(m/form % options))
      (apply f (conj children options))]))
 
-(defn -util-schema [{:keys [type min max childs type-properties fn]}]
-  ^{:type ::m/into-schema}
-  (reify m/IntoSchema
-    (-type [_] type)
-    (-type-properties [_] type-properties)
-    (-properties-schema [_ _])
-    (-children-schema [_ _])
-    (-into-schema [parent properties children options]
-      (m/-check-children! type properties children min max)
-      (let [[children forms schema] (fn properties (vec children) options)
-            form (delay (m/-create-form type properties forms options))
-            cache (m/-create-cache options)]
-        ^{:type ::m/schema}
-        (reify
-          m/Schema
-          (-validator [_] (m/-validator schema))
-          (-explainer [_ path] (m/-explainer schema path))
-          (-parser [_] (m/-parser schema))
-          (-unparser [_] (m/-unparser schema))
-          (-transformer [this transformer method options]
-            (m/-parent-children-transformer this [schema] transformer method options))
-          (-walk [this walker path options]
-            (let [children (if childs (subvec children 0 childs) children)]
-              (when (m/-accept walker this path options)
-                (m/-outer walker this path (m/-inner-indexed walker path children options) options))))
-          (-properties [_] properties)
-          (-options [_] options)
-          (-children [_] children)
-          (-parent [_] parent)
-          (-form [_] @form)
-          m/Cached
-          (-cache [_] cache)
-          m/LensSchema
-          (-keep [_])
-          (-get [_ key default] (clojure.core/get children key default))
-          (-set [_ key value] (m/into-schema type properties (clojure.core/assoc children key value)))
-          m/RefSchema
-          (-ref [_])
-          (-deref [_] schema))))))
+(defn -util-schema [m] (m/-proxy-schema m))
 
 (defn -merge [] (-util-schema {:type :merge, :fn (-reducing merge)}))
 (defn -union [] (-util-schema {:type :union, :fn (-reducing union)}))