Somewhere between multimethods and pattern matching lies Saturn.

saturn.clj

(ns saturn)

;; ---------------------------------------------------------------------
;; Signature parsing

(defprotocol IParse
  (-parse [x]))


(extend-protocol IParse
  clojure.lang.Symbol
  (-parse [sym]
    (let [pattern (when-let [maybe-tag (:tag (meta sym))]
                    (when (symbol? maybe-tag)
                      (let [x (resolve maybe-tag)]
                        (cond
                          (instance? java.lang.Class x)
                          {:tag ::type-pattern
                           :type x
                           :binding sym}

                          (var? x)
                          (let [y @x]
                            (if (ifn? y)
                              {:tag ::predicate-pattern
                               :predicate y
                               :binding sym}
                              {:tag ::value-pattern
                               :value y
                               :binding sym}))

                          :else
                          {:tag ::object-pattern
                           :binding sym}))))]
      (or pattern {:tag ::object-pattern
                   :type Object
                   :binding sym})))

  Object
  (-parse [x]
    {:tag ::value-pattern
     :value x
     :binding (gensym)}))


(defn parse-signature [parameters]
  (map -parse parameters))

(defn- add-signature* [signature-map parsed-signature f]
  (let [argc (count parsed-signature)
        path (cons argc parsed-signature)]
    (assoc-in signature-map path f)))

(defn add-signature [signature-map unparsed-signature f]
  (add-signature* signature-map (parse-signature unparsed-signature) f))

(defn add-signatures
  [signature-map sigs+fns]
  (reduce
   (fn [sigs [sig fn]]
     (add-signature sigs sig fn))
   signature-map
   sigs+fns))

;; ---------------------------------------------------------------------
;; Pattern matching

(defn match-pattern [pattern value]
  (case (:tag pattern)
    ;; Value constraint
    ::value-pattern
    (= value (:value pattern))

    ;; Predicate constraint
    ::predicate-pattern
    (try
      (boolean ((:predicate pattern) value))
      (catch Exception _
        false))

    ;; Type constraint
    ::type-pattern
    (instance? (:type pattern) value)

    ;; Wildcard
    ::object-pattern
    true))

(defn score [x]
  (case (:tag x)
    ::value-pattern 0
    ::predicate-pattern 1
    ::type-pattern 2
    ::object-pattern 3
    4))

(defn derive-match-column [signatures]
  (sort
   (fn [[ka _] [kb _]]
     (compare (score ka)
              (score kb)))
   signatures))

(defn match-parameter [signatures v]
  (let [column (derive-match-column signatures)]
    (some
     (fn [[p x]]
       (when (match-pattern p v)
         [p x]))
     column)))

;; ---------------------------------------------------------------------
;; State machine

(defn make-initial-state [sigs args]
  {:prev nil
   :next {:args (vec args)
          :sigs sigs}})

(defn success-state? [state]
  (and (empty? (:args (:next state)))
       (fn? (:sigs (:next state)))))

(defn backtrack [state]
  (let [pargs (:args (:prev state))
        nargs (:args (:next state))
        pargs' (pop pargs)
        nargs' (cons (peek pargs) nargs)
        psigs (:sigs (:prev state))
        nsigs' (dissoc psigs (:match (:prev state)))]
    {:prev {:args pargs'}
     :next {:args nargs'
            :sigs nsigs'}}))

(defn run-state [state]
  (let [psigs (:sigs (:prev state))
        pargs (:args (:prev state))
        nsigs (:sigs (:next state))
        nargs (:args (:next state))
        arg (first nargs)]
    (if (success-state? state)
      [::success (:sigs (:next state))]
      (if-let [[match nsigs'] (match-parameter nsigs arg)]
        (recur {:prev {:args ((fnil conj []) pargs arg)
                       :sigs nsigs
                       :match match}
                :next {:args (rest nargs)
                       :sigs nsigs'}})
        (if (empty? (:args (:prev state)))
          [::fail (constantly ::fail)]
          (recur (backtrack state)))))))

(defn match-signature [signatures arguments]
  (let [argc (count arguments)
        signature (get signatures argc)
        state (make-initial-state signature arguments)
        [result f] (run-state state)]
    (apply f arguments)))

(deftype Function [signatures]
  clojure.lang.IFn
  (invoke [_]
    (match-signature @signatures []))
  (invoke [_ a]
    (match-signature @signatures [a]))
  (invoke [_ a b]
    (match-signature @signatures [a b]))
  (invoke [_ a b c]
    (match-signature @signatures [a b c]))
  (invoke [_ a b c d]
    (match-signature @signatures [a b c d]))
  (invoke [_ a b c d e]
    (match-signature @signatures [a b c d e]))
  (invoke [_ a b c d e f]
    (match-signature @signatures [a b c d e f]))
  (invoke [_ a b c d e f g]
    (match-signature @signatures [a b c d e f g]))
  (invoke [_ a b c d e f g h]
    (match-signature @signatures [a b c d e f g h]))
  (invoke [_ a b c d e f g h i]
    (match-signature @signatures [a b c d e f g h i]))
  (invoke [_ a b c d e f g h i j]
    (match-signature @signatures [a b c d e f g h i j]))
  (invoke [_ a b c d e f g h i j k]
    (match-signature @signatures [a b c d e f g h i j k]))
  (invoke [_ a b c d e f g h i j k l]
    (match-signature @signatures [a b c d e f g h i j k l]))
  (invoke [_ a b c d e f g h i j k l m]
    (match-signature @signatures [a b c d e f g h i j k l m]))
  (invoke [_ a b c d e f g h i j k l m n]
    (match-signature @signatures [a b c d e f g h i j k l m n]))
  (invoke [_ a b c d e f g h i j k l m n o]
    (match-signature @signatures [a b c d e f g h i j k l m n o]))
  (invoke [_ a b c d e f g h i j k l m n o p]
    (match-signature @signatures [a b c d e f g h i j k l m n o p]))
  (invoke [_ a b c d e f g h i j k l m n o p q]
    (match-signature @signatures [a b c d e f g h i j k l m n o p q]))
  (invoke [_ a b c d e f g h i j k l m n o p q r]
    (match-signature @signatures [a b c d e f g h i j k l m n o p q r]))
  (invoke [_ a b c d e f g h i j k l m n o p q r s]
    (match-signature @signatures [a b c d e f g h i j k l m n o p q r s]))
  (invoke [_ a b c d e f g h i j k l m n o p q r s t]
    (match-signature @signatures [a b c d e f g h i j k l m n o p q r s t]))
  (invoke [_ a b c d e f g h i j k l m n o p q r s t u]
    (match-signature @signatures [a b c d e f g h i j k l m n o p q r s t u])))

(defn make-function
  ([]
   (Function. (atom {})))
  ([sigs+fns]
   (let [sigs (add-signatures {} sigs+fns)]
     (Function. (atom sigs)))))

(defn sig-bindings [sig]
  (mapv (fn [pattern]
          (vary-meta (:binding pattern) dissoc :tag))
        (parse-signature sig)))

(defmacro fun [& fn-specs]
  (let [[sym fn-tail] (if (symbol? (first fn-specs))
                        [(first fn-specs) (rest fn-specs)]
                        [(gensym) fn-specs])
        fn-tail (if (vector? (first fn-tail))
                  (list fn-tail)
                  fn-tail)
        sigs+fns (mapv
                  (fn [[sig & fn-body]]
                    (let [bdgs (sig-bindings sig)]
                      `['~sig (fn ~bdgs ~@fn-body)]))
                  fn-tail)]
    `(let [~sym (make-function)]
       (swap! (.signatures ~(vary-meta sym assoc :tag `Function))
              add-signatures
              ~sigs+fns)
       ~sym)))

(defmacro defun [sym & fn-specs]
  `(def ~sym (fun ~@fn-specs)))

(defmacro defsig [sym sig & fn-body]
  (let [maybe-var (resolve sym)]
    (if (and (var? maybe-var)
             (instance? Function @maybe-var))
      (let [bdgs (sig-bindings sig)]
        `(do
           (swap! (.signatures ~(vary-meta sym assoc :tag `Function))
                  add-signature
                  '~sig
                  (fn ~bdgs ~@fn-body))
           ~maybe-var)))))

;; ---------------------------------------------------------------------
;; Example

(comment 
  (defrecord Pixel [value])

  (defun add)

  (defsig add
    [^Number a ^Number b]
    (+ a b))

  (defsig add
    [^Number a ^Pixel b]
    (Pixel. (+ a (:value b))))

  (defsig add
    [^Pixel a ^Number b]
    (Pixel. (+ (:value a) b)))

  (defsig add
    [^Pixel a ^Pixel b]
    (Pixel. (+ (:value a)
               (:value b))))

  (defsig add
    [^clojure.lang.PersistentVector v]
    (reduce add v))

  (defsig add [] 0)
  (defsig add [_] 0)
  (defsig add [_ _] 0)
  (defsig add [7 7] 7000)

  (add)
  ;; => 0
  (add 1 2)
  ;; => 3
  (add [1 2 3])
  ;; => 6
  (add (Pixel. 1) 3)
  ;; #foo.Pixel{:value 4}
  (add 3 (Pixel. 1))
  ;; #foo.Pixel{:value 4}
  (add [(Pixel. 1) 2 3])
  ;; => #foo.Pixel{:value 6}
  (add 7 7)
  ;; => 7000
  )