Skip to content

Instantly share code, notes, and snippets.

@noprompt
Last active March 9, 2016 00:01
Show Gist options
  • Save noprompt/fa768ecca48d559c8023 to your computer and use it in GitHub Desktop.
Save noprompt/fa768ecca48d559c8023 to your computer and use it in GitHub Desktop.
Somewhere between multimethods and pattern matching lies Saturn.
(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
)
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment