WIP: Support vector syntax for references

src/malli/core.cljc

@@ -177,7 +177,9 @@
        (when (or (and min (< size ^long min)) (and max (> size ^long max)))
          (-fail! ::child-error {:type type, :properties properties, :children children, :min min, :max max}))))))
 
-(defn -pointer [id schema options] (-into-schema (-schema-schema {:id id}) nil [schema] options))
+(defn -pointer
+  ([id schema options] (-pointer id schema nil options))
+  ([id schema properties options] (-into-schema (-schema-schema {:id id}) properties [schema] options)))
 
 (defn -reference? [?schema] (or (string? ?schema) (qualified-ident? ?schema) (var? ?schema)))
 
@@ -272,6 +274,13 @@
         (cond-> ?schema rec (recur ?form f rec options))
         (-fail! ::invalid-schema {:schema ?schema, :form ?form}))))
 
+(defn- -lookup-into-schema [?schema options]
+  (if (into-schema? ?schema)
+    ?schema
+    (let [?schema (mr/-schema (-registry options) ?schema)]
+      (when (into-schema? ?schema)
+        ?schema))))
+
 (defn -properties-and-options [properties options f]
   (if-let [r (:registry properties)]
     (let [options (-update options :registry #(mr/composite-registry r (or % (-registry options))))]
@@ -1649,7 +1658,7 @@
            Cached
            (-cache [_] cache)
            LensSchema
-           (-get [_ key default] (if (= key 0) (-pointer ref (rf) options) default))
+           (-get [_ key default] (if (= key 0) (-pointer ref (rf) nil options) default))
            (-keep [_])
            (-set [this key value] (if (= key 0) (-set-children this [value])
                                                 (-fail! ::index-out-of-bounds {:schema this, :key key})))
@@ -1682,8 +1691,14 @@
         (-check-children! type properties children 1 1)
         (let [children (-vmap #(schema % options) children)
               child (nth children 0)
-              form (delay (or (and (empty? properties) (or id (and raw (-form child))))
-                              (-simple-form parent properties children -form options)))
+              child-children (not-empty (-children child))
+              form (delay (let [no-props? (empty? properties)]
+                            (or (when id
+                                  (if (and no-props? (not child-children))
+                                    id
+                                    (into [id properties] child-children)))
+                                (and no-props? raw (-form child))
+                                (-simple-form parent properties children -form options))))
               cache (-create-cache options)]
           ^{:type ::schema}
           (reify
@@ -2164,14 +2179,25 @@
      (schema? ?schema) ?schema
      (into-schema? ?schema) (-into-schema ?schema nil nil options)
      (vector? ?schema) (let [v #?(:clj ^IPersistentVector ?schema, :cljs ?schema)
-                             t (-lookup! #?(:clj (.nth v 0), :cljs (nth v 0)) v into-schema? true options)
+                             v0 #?(:clj (.nth v 0), :cljs (nth v 0))
                              n #?(:bb (count v) :clj (.count v), :cljs (count v))
-                             ?p (when (> n 1) #?(:clj (.nth v 1), :cljs (nth v 1)))]
-                         (if (or (nil? ?p) (map? ?p))
-                           (into-schema t ?p (when (< 2 n) (subvec ?schema 2 n)) options)
-                           (into-schema t nil (when (< 1 n) (subvec ?schema 1 n)) options)))
+                             ?p (when (> n 1) #?(:clj (.nth v 1), :cljs (nth v 1)))
+                             props? (or (nil? ?p) (map? ?p))
+                             properties (when props? ?p)
+                             children (if props?
+                                        (when (< 2 n) (subvec ?schema 2 n))
+                                        (when (< 1 n) (subvec ?schema 1 n)))]
+                         (if-some [t (-lookup-into-schema v0 options)]
+                           (into-schema t properties children options)
+                           (if-let [?schema' (and (-reference? v0) (-lookup v0 options))]
+                             (let [inner (schema ?schema' options)]
+                               (when (seq (-children inner))
+                                 (when (seq children)
+                                   (-fail! ::cannot-provide-children-to-schema {:schema ?schema})))
+                               (-pointer v0 (-set-children inner children) properties options))
+                             (-fail! ::invalid-schema {:schema ?schema}))))
      :else (if-let [?schema' (and (-reference? ?schema) (-lookup ?schema options))]
-             (-pointer ?schema (schema ?schema' options) options)
+             (-pointer ?schema (schema ?schema' options) nil options)
              (-> ?schema (-lookup! ?schema nil false options) (recur options))))))
 
 (defn form

test/malli/core_test.cljc

@@ -3372,3 +3372,50 @@
                    :errors [{:path [::m/in :y], :in [:y], :schema y-schema, :value "2"}]}
                   explain))
     (is (form= y-schema (mu/get-in schema (-> explain :errors first :path))))))
+
+(deftest local-registry-shadow-test
+  (let [options {:registry (assoc (m/default-schemas) ::string (:string (m/default-schemas)))}
+        validate #(m/validate %1 %2 options)]
+    (is (m/schema ::string options))
+    (is (m/schema [::string] options))
+    (is (m/schema [::string {:foo :bar}] options))
+    (is (m/schema [::string {:foo :bar}] options))
+    (is (validate ::string "a"))
+    (is (not (validate ::string 1)))
+    (is (validate [:schema {:registry {::string :int}} ::string] 1))
+    (is (= [:schema {:registry {::string :int}} ::string]
+           (-> [:schema {:registry {::string :int}} ::string]
+               (m/form options))))
+    (is (validate [:schema {:registry {::string :int}} [::string {:foo :bar}]] 1))
+    (is (= [:schema {:registry {::string :int}} [::string {:foo :bar}]]
+           (-> [:schema {:registry {::string :int}} [::string {:foo :bar}]]
+               (m/form options))))
+    (is (= [:schema {:registry {::string [:tuple :int]}} [::string {:foo :bar}]]
+           (-> [:schema {:registry {::string [:tuple :int]}} [::string {:foo :bar}]]
+               (m/form options))))
+    (is (not (validate [:schema {:registry {::string :int}} [::string]] "a")))
+    (is (not (validate [:schema {:registry {::string :int}} [::string {:foo :bar}]] "a")))))
+
+(deftest references-vector-syntax-test
+  (is (= {:doc ""}
+         (-> (m/schema [:schema {:registry {::a [:tuple :int :int]}}
+                        [::a {:doc ""}]])
+             m/deref
+             m/properties)))
+  (is (thrown-with-msg?
+        #?(:clj Exception, :cljs js/Error)
+        #":malli\.core/references-do-not-support-children"
+        (m/schema [:schema {:registry {::a [:tuple :int :int]}}
+                   [::a {:doc ""} :int]])))
+  (let [options {:registry (assoc (m/default-schemas) ::string [:tuple :int])}
+        validate #(m/validate %1 %2 options)]
+    (is (validate ::string [1]))
+    (is (not (validate ::string 1)))
+    (is (validate [::string] [1]))
+    (is (not (validate [::string] 1)))
+    (is (validate [::string {:foo :bar}] [1]))
+    (is (not (validate [::string {:foo :bar}] 1)))
+    (is (= {:foo :bar}
+           (-> [::string {:foo :bar}]
+               (m/schema options)
+               m/properties)))))

test/malli/registry_test.cljc

@@ -4,13 +4,27 @@
             [malli.registry :as mr]))
 
 (deftest mutable-test
-  (let [registry* (atom {})
+  (let [registry* (atom (m/default-schemas))
         registry (mr/mutable-registry registry*)
         register! (fn [t ?s] (swap! registry* assoc t ?s))]
-    (testing "default registy"
+    (testing "default registry"
       (is (thrown? #?(:clj Exception, :cljs js/Error) (m/validate :str "kikka" {:registry registry})))
       (register! :str (m/-string-schema))
-      (is (true? (m/validate :str "kikka" {:registry registry}))))))
+      (is (true? (m/validate :str "kikka" {:registry registry})))
+      (register! ::foo (m/schema [:tuple :int]))
+      (is (= ::foo
+             (-> (m/schema ::foo {:registry registry})
+                 m/form)))
+      (is (= [::foo {:doc ""}]
+             (-> (m/schema [::foo {:doc ""}] {:registry registry})
+                 m/form)))
+      (register! ::bare [:tuple :int])
+      (is (= ::bare
+             (-> (m/schema ::bare {:registry registry})
+                 m/form)))
+      (is (= [::bare {:doc ""}]
+             (-> (m/schema [::bare {:doc ""}] {:registry registry})
+                 m/form))))))
 
 (deftest composite-test
   (let [registry* (atom {})