malli.relations.clj

(ns malli.relations
  (:require
   [clojure.spec.alpha :as s]
   [clojure.test.check.generators :as gen]
   [clojure.string :as str]
   [malli.core :as m]
   [malli.generator :as mg]
   [malli.registry :as mr]
   #_:reload-all))

(defn -wildcard-schema [] [:= '_])
(s/def ::_ #{'_})
(s/def ::wildcard #{'_})

;;; fn-arg                     = (variable | constant | src-var)
(defn -fn-arg-schema [] [:orn
                         [:variable :variable]
                         [:constant :constant]
                         [:src-var :src-var]])
(s/def ::fn-arg (s/or :variable ::variable
                      :constant ::constant
                      :src-var  ::src-var))

;;; with-clause                = ':with' variable+
;;; where-clauses              = ':where' clause+
;;; inputs                     = ':in' (src-var | binding | pattern-name | rules-var)+

;;; src-var                    = symbol starting with "$"

(defn src-var-symbol? [s] (str/starts-with? s "$"))

(defn -src-var-schema [] (m/-simple-schema
                          {:type :variable,
                           :pred #(and (simple-symbol? %) (src-var-symbol? %))}))

(s/def ::src-var (s/and simple-symbol? src-var-symbol?))

;;; variable          = symbol starting with "?"
(defn variable-symbol? [s] (str/starts-with? s "?"))

(defn -variable-schema [] (m/-simple-schema
                           {:type :variable,
                            :pred (fn [s] (and (simple-symbol? s)
                                              (variable-symbol? s)))}))

(s/def ::variable (s/and simple-symbol? variable-symbol?))

(defmethod mg/-schema-generator :variable [_ _] (gen/fmap #(symbol (str "?" %)) gen/string-alphanumeric))

(comment
  (mg/generate (-variable-schema)))
(comment
  (m/validate (-variable-schema) '?a)
  (m/validate (-variable-schema) 'a))

;;; rules-var         = the symbol "%"
;;; plain-symbol      = symbol that does not begin with "$" or "?"
(defn -plain-symbol-schema [] [:and simple-symbol? [:not :src-var] [:not :variable]])
(s/def ::plain-symbol (s/and simple-symbol? #(not (or (str/starts-with? (str %) "?")
                                                      (str/starts-with? (str %) "$")))))
;;; pattern-name      = plain-symbol
;;; and-clause        = [ 'and' clause+ ]
(defn -and-clause-schema [] [:cat [:= 'and] [:+ [:schema [:ref ::clause]]]])
(s/def ::and-clause (s/cat :and #{'and} :clauses (s/+ ::clause)))
;;; expression-clause = (data-pattern | pred-expr | fn-expr | rule-expr)
(defn -expression-clause-schema [] [:orn
                                    [:pred-expr :pred-expr]
                                    [:fn-expr :fn-expr]
                                    [:rule-expr :rule-expr]
                                    [:data-pattern :data-pattern]])
(s/def ::expression-clause (s/or :data-pattern ::data-pattern
                                 :pred-expr ::pred-expr
                                 :fn-expr ::fn-expr
                                 :rule-expr ::rule-expr))
;;; rule-expr         = [ src-var? rule-name (variable | constant | '_')+]
(defn -rule-expr-schema [] [:catn
                            [:src-var [:? :src-var]]
                            [:rule-name :symbol]
                            [:+ [:altn
                                 [:variable :variable]
                                 [:constant :constant]
                                 [:wildcard :wildcard]]]])
(s/def ::rule-expr (s/cat :src-var (s/? ::src-var)
                          ::rule-name (s/+ (s/alt :variable ::variable
                                                  :constant ::constant
                                                  :_ ::_))))
;;; not-clause        = [ src-var? 'not' clause+ ]
(defn -not-clause-schema [] [:catn
                             [:src [:? :src-var]]
                             [:not [:= 'not]]
                             [:clauses [:+ [:schema [:ref ::clause]]]]])
(s/def ::not-clause (s/cat :src-var (s/? ::src-var)
                           :not #{'not}
                           :clauses (s/+ ::clause)))
;;; not-join-clause   = [ src-var? 'not-join' [variable+] clause+ ] TODO
;;; or-clause         = [ src-var? 'or' (clause | and-clause)+]
(defn -or-clause-schema [] [:catn
                            [:src [:? :src-var]]
                            [:or [:= 'or]]
                            [:clauses [:+ [:alt [:schema [:ref ::clause]] [:schema [:ref ::and-clause]]]]]])
(s/def ::or-clause (s/cat :src-var (s/? ::src-var)
                          :or #{'or}
                          :clauses (s/+ (s/alt :clause ::clause :and-clause ::and-clause))))
;;; or-join-clause    = [ src-var? 'or-join' rule-vars (clause | and-clause)+ ] TODO
;;; rule-vars         = [variable+ | ([variable+] variable*)]
(defn -rule-vars-schema [] [:alt [:+ :variable] [:cat [:sequential {:min 1} :variable] [:* :variable]]])
(s/def ::rule-vars (s/alt :variable (s/+ :variable)
                          :variables (s/cat :variable (s/+ :variable)
                                            :variables (s/* :variable))))
;;; clause            = (not-clause | not-join-clause | or-clause | or-join-clause | expression-clause)
(defn -clause-schema [] [:orn
                         [:not-clause [:schema [:ref ::not-clause]]]
                         [:or-clause [:schema [:ref ::or-clause]]]
                         [:expression-clause :expression-clause]])
(s/def ::clause (s/or :not-clause ::not-clause
                      :or-clause ::or-clause
                      :expression-clause ::expression-clause))
;;; data-pattern      = [ src-var? (variable | constant | '_')+ ]
(defn -data-pattern-schema [] [:catn
                               [:src-var [:? :src-var]]
                               [:pattern [:+ [:altn [:variable :variable] [:constant :constant] [:wildcard :wildcard]]]]])
(s/def ::data-pattern (s/cat :src-var (s/? ::src-var)
                             :pattern (s/+ (s/alt :variable ::variable
                                                  :constant ::constant
                                                  :_ ::_))))
;;; constant          = any non-variable data literal
(defn -constant-schema [] [:and :any [:not :variable]])
(s/def ::constant (s/or :symbol (s/and simple-symbol? (complement variable-symbol?) (complement src-var-symbol?))
                        :keyword keyword?
                        :string string?
                        :number number?
                        :set set?
                        :map map?
                        :list list?
                        :vector vector?))
;;; pred-expr         = [ [pred fn-arg+] ]
(defn -pred-expr-schema [] [:sequential {:min 1 :max 1} [:cat :pred [:+ :fn-arg]]])
(s/def ::pred-expr (s/cat :pred-expr (s/cat :pred ::pred :fn-args (s/+ ::fn-arg))))
(def preds '#{= == <= >= < > contains? starts-with?})
(defn -pred-schema [] (into [:enum] preds))
(s/def ::pred preds)
;;; fn-expr           = [ [fn fn-arg+] binding]
(defn -fn-expr-schema [] [:cat [:cat :function [:+ :fn-arg]] :binding])
(s/def ::fn-expr (s/cat :fn-expr (s/cat :function ::function :fn-args (s/+ ::fn-arg))
                        :binding ::binding))
(def functions '#{+ - * / quot subs})
(defn -function-schema [] (into [:enum] functions))
(s/def ::function functions)
;;; binding           = (bind-scalar | bind-tuple | bind-coll | bind-rel)
(defn -binding-schema [] [:orn
                          [:bind-scalar :bind-scalar]
                          [:bind-tuple :bind-tuple]
                          [:bind-coll :bind-coll]
                          [:bind-rel :bind-rel]
                          ])
(s/def ::binding (s/or :bind-scalar ::bind-scalar
                       :bind-tuple ::bind-tuple
                       :bind-coll ::bind-coll
                       :bind-rel ::bind-rel))
;;; bind-scalar       = variable
(defn -bind-scalar-schema [] :variable)
(s/def ::bind-scalar ::variable)
;;; bind-tuple        = [ (variable | '_')+]
(defn -bind-tuple-schema [] [:cat [:+ [:alt :variable :wildcard]]])
(s/def ::bind-tuple (s/cat :bindings (s/+ (s/alt :variable ::variable
                                                 :_ ::_))))
;;; bind-coll         = [variable '...']
(defn -bind-coll-schema [] [:cat :variable [:= '...]])
(s/def ::bind-coll (s/cat :variable ::variable :rest '#{...}))
;;; bind-rel          = [ [(variable | '_')+] ]
(defn -bind-rel-schema [] [:cat [:cat [:+ [:alt :variable :wildcard]]]])
(s/def ::bind-rel (s/cat :rel (s/cat :bindings (s/+ (s/alt :variable ::variable
                                                           :_ ::_)))))

(defn relational-schemas
  []
  {:wildcard          (-wildcard-schema)
   :_                 (-wildcard-schema)
   :src-var           (-src-var-schema)
   :variable          (-variable-schema)
   :plain-symbol      (-plain-symbol-schema)
   ::and-clause       (-and-clause-schema)
   :expression-clause (-expression-clause-schema)
   :rule-expr         (-rule-expr-schema)
   ::not-clause       (-not-clause-schema)
   ::or-clause        (-or-clause-schema)
   :rule-vars         (-rule-vars-schema)
   ::clause           (-clause-schema)
   :data-pattern      (-data-pattern-schema)
   :constant          (-constant-schema)
   :pred-expr         (-pred-expr-schema)
   :pred              (-pred-schema)
   :fn-expr           (-fn-expr-schema)
   :fn-arg            (-fn-arg-schema)
   :function          (-function-schema)
   :binding           (-binding-schema)
   :bind-scalar       (-bind-scalar-schema)
   :bind-tuple        (-bind-tuple-schema)
   :bind-coll         (-bind-coll-schema)
   :bind-rel          (-bind-rel-schema)})

(defn default-schemas []
  (merge (m/default-schemas) (relational-schemas)))

(def default-registry (mr/registry (default-schemas)))

(comment
  (s/valid? ::clause '[?e :x ?x])
  (s/conform ::clause '[?e :x ?x])
  (s/conform (s/+ ::clause)
             '[[?e :x ?x]
               (not
                [?e :y]
                [?e :z])]))

(comment
  (def _ (m/schema ::not-clause {:registry default-registry}))
  (m/schema ::clause {:registry default-registry})
  (m/validate ::clause '[?e :x ?x] {:registry default-registry})
  (m/schema
   [:schema
    {:registry (relational-schemas)}
    ::clause]
   #_   '[?e :x ?x])

  (m/validate
   [:schema
    {:registry (relational-schemas)}
    ::clause]
   '[?e :x ?x])

  (m/parse
   [:schema
    {:registry (relational-schemas)}
    ::clause]
   '[?e :x ?x])

  (m/parse
   [:schema
    {:registry (relational-schemas)}
    [:+ ::clause]]
   '[[?e :x ?x]
     [?e :y ?y]
     [(< ?x ?y)]])

  (m/validate
   [:schema {:registry {::ping [:maybe [:tuple [:= "ping"] [:ref ::pong]]]
                        ::pong [:maybe [:tuple [:= "pong"] [:ref ::ping]]]}}
    ::ping]
   ["ping" ["pong" ["ping" ["pong" ["ping" nil]]]]]))