diff --git a/src/cljs/emptyhead/newlib/core.cljs b/src/cljs/emptyhead/newlib/core.cljs new file mode 100644 index 0000000..a098849 --- /dev/null +++ b/src/cljs/emptyhead/newlib/core.cljs @@ -0,0 +1,26 @@ +(ns emptyhead.newlib.core + "Generic core thoughts." + (:require [emptyhead.thought.define :as def] + [emptyhead.thought.crud :as thought] + [emptyhead.idea.crud :as idea])) + +;; No-op: do nothing. +(def/define! [:EH :CORE :NOP] + (fn [_thought parent] + [parent nil])) + +;; Container: Used for chaining multiple operations. Returns intself rather than its parent! +(def/define! [:EH :CORE :CONTAINER] + (fn [thought _parent] + [thought nil])) + +;; Puts data field of `thought` onto `parent` stack. +(def/define! [:EH :IO :RETURN] + (fn [thought parent] + [parent (thought/data thought)])) + +;; Forget idea stored in `thought`'s data. Used to make destructors. +(def/define! [:EH :IDEA :FORGET] + (fn [thought parent] + (idea/forget-idea! (thought/data thought)) + [parent nil])) diff --git a/src/cljs/emptyhead/newlib/delegate.cljs b/src/cljs/emptyhead/newlib/delegate.cljs new file mode 100644 index 0000000..f64f741 --- /dev/null +++ b/src/cljs/emptyhead/newlib/delegate.cljs @@ -0,0 +1,36 @@ +(ns emptyhead.newlib.delegate + "Delegation: treat one message as though it were another, enabling behaviour sharing and polymorphism." + (:require [emptyhead.thought.crud :as thought] + [emptyhead.idea.crud :as idea] + [emptyhead.thought.define :as def] + [emptyhead.thought.eval :as eval] + [emptyhead.thought.extend :as extend] + [emptyhead.newlib.core])) + +(defn remove-delegate + "Undelegate `del` from `msg`." + [msg del] + (let [remover (thought/register-thought! [:EH :CORE :NOP] :ext-stages [[:EH :MSG :REMOVE-DELEGATE msg del]])] + (eval/execute! remover))) + +;; FIXME Delegate order is currently undefined! Give this a proper order. +(defn add-delegate + "Register `del` as a delegate for `msg`: implementations defined for `del` will now run trigger on `msg` as well. + For instance, if message =(:foo :bar)= is defined and we =(add-delegate :quux :bar)= then =(:foo :quux)= will alias to =(:foo :bar)=. + Note that this also works on the left hand side." + [msg del] + (remove-delegate msg del) + (let [delegator (thought/register-thought! + [:EH :IO :RETURN] + :data del + :transient false) + remover (thought/register-thought! [:EH :IDEA :FORGET] :data delegator)] + (extend/register-extension! delegator [:EH :MSG :DELEGATE msg]) + (extend/register-extension! remover [:EH :MSG :REMOVE-DELEGATE msg del]))) + +(defn get-delegates + "Get possible delegates for `msg`." + [msg] + (let [stage [:EH :MSG :DELEGATE msg]] + (-> (thought/register-thought! [:EH :CORE :CONTAINER] :ext-stages [stage]) + eval/execute! thought/pop-stack second))) diff --git a/src/cljs/emptyhead/newlib/lazy.cljs b/src/cljs/emptyhead/newlib/lazy.cljs new file mode 100644 index 0000000..03c560c --- /dev/null +++ b/src/cljs/emptyhead/newlib/lazy.cljs @@ -0,0 +1 @@ +(ns emptyhead.newlib.lazy) diff --git a/src/cljs/emptyhead/newlib/math/arithmetic.cljs b/src/cljs/emptyhead/newlib/math/arithmetic.cljs new file mode 100644 index 0000000..cd4a793 --- /dev/null +++ b/src/cljs/emptyhead/newlib/math/arithmetic.cljs @@ -0,0 +1,29 @@ +(ns emptyhead.newlib.math.arithmetic + "Airthmetic operators." + (:require [emptyhead.thought.define :as def] + [emptyhead.thought.crud :as thought] + [emptyhead.newlib.message :as msg])) + +;; Initial addition, e.g. =5 +=. Returns partially applied pointer. +(def/define! [:EH :PRIM [:EH :PRIM :NUM] :+] + (fn [thought parent] + (let [to (:to (thought/data parent)) + pointer (-> (str "PART<" to "+_>.") gensym keyword) + th (thought/register-thought! [:EH :PRIM :PARTIAL :+] :transient false :data to)] + (msg/register-impl pointer [:EH :PRIM :NUM] th) + [parent pointer]))) + +;; Final addition, e.g. =(5 +) 5=. Returns a thunk. +(def/define! [:EH :PRIM :PARTIAL :+] + (fn [thought parent] + (let [from (:from (thought/data parent)) + to (thought/data thought) + pointer (-> (str "LAZY<" from "+" to">.") gensym keyword) + lazy (thought/register-thought! [:EH :PRIM :LAZY :+] :transient true :data [from to])] + (msg/register-impl pointer [:EH :PRIM :REIFY] lazy) + [parent pointer]))) + +(def/define! [:EH :PRIM :LAZY :+] + (fn [thought parent] + (let [[from to] (thought/data thought)] + [parent (+ from to)]))) diff --git a/src/cljs/emptyhead/newlib/math/number.cljs b/src/cljs/emptyhead/newlib/math/number.cljs new file mode 100644 index 0000000..94188cb --- /dev/null +++ b/src/cljs/emptyhead/newlib/math/number.cljs @@ -0,0 +1,3 @@ +(ns emptyhead.newlib.math.number + (:require [emptyhead.thought.define :as def])) + diff --git a/src/cljs/emptyhead/newlib/message.cljs b/src/cljs/emptyhead/newlib/message.cljs new file mode 100644 index 0000000..ef2d2a2 --- /dev/null +++ b/src/cljs/emptyhead/newlib/message.cljs @@ -0,0 +1,104 @@ +(ns emptyhead.newlib.message + "Core message handling code." +(:require [emptyhead.thought.define :as def] + [emptyhead.thought.crud :as thought] + [emptyhead.thought.eval :as eval] + [emptyhead.thought.return :as return] + [emptyhead.idea.protocol :as prtc] + [emptyhead.idea.crud :as idea] + [emptyhead.thought.extend :as extend] + [emptyhead.newlib.delegate :as delegate] + [emptyhead.newlib.core])) + +(defn register-impl + "Register thought `th` as implementation for message [`to` `from`]. Implementations are implemented as extensions." + [to from th] + (let [impl-prop [:EH :IMPL to from] + existing (first (extend/extensions-of-stage impl-prop))] + (when (and existing (not= th (prtc/reference existing))) + (extend/remove-extension! existing impl-prop)) + (extend/register-extension! th impl-prop))) + +;; TODO Proper warnings when intend impl does not exist +(defn register-single-impl + "Wrapper around register-impl for singleton operators." + [to from impl] + (let [th (prtc/reference (thought/get-singleton impl))] + (register-impl to from th))) + +(defn apply-ext + "Attach singleton `single` to extension property `ext`." + [single ext] + (let [th (thought/get-singleton single)] + (extend/register-extension! th ext))) + + +(defn apply-msg + "Apply a message; this is the entry point of execution. Applying a message is a step process: + Deref -> Find all (direct) delegates that might be in play; + Parse -> Find delegates for 'parseable' values like numbers; + Match -> Iterate through delegate combinations until an implementation is found." + [to from] + (let [th (thought/register-thought! + [:EH :CORE :CONTAINER] + :ext-stages [[:EH :MSG :RESOLVE :DEREF] + [:EH :MSG :RESOLVE :PARSE] + [:EH :MSG :RESOLVE :MATCH]] + :return [from to])] + (second (thought/pop-stack (eval/execute! th))))) + +(defn multi-msg + "Apply multiple messages sequentially. =(:foo :bar :baz)= <-> =((:foo :bar) :baz)." + [& msgs] + (reduce apply-msg msgs)) + +;; Deref: find `to` and `from` delegates. +(def/define! [:EH :MSG :DEREF] + (fn [thought parent] + (let [[parent to] (thought/pop-stack parent) + [parent from] (thought/pop-stack parent) + to-dels (delegate/get-delegates to) + from-dels (delegate/get-delegates from) + parent (assoc parent :data {:to to :from from :delegates {to (conj to-dels to) from (conj from-dels from)}})] + [parent nil]))) + + +;; Will delegate numbers to =[:EH :PRIM :NUM]=. +(def/define! [:EH :MSG :PARSE-NUM] + (fn [thought parent] + (let [nums (filter number? (keys (-> parent :data :delegates))) + updater (fn [p n] (update-in p [:data :delegates n] conj [:EH :PRIM :NUM])) + parent (reduce updater parent nums)] + [parent nil]))) + + +;; For delegate sets [[A B] [X Y]] will search implementations in [[A X] [A Y] [B X] [B Y]] order until one is found. +(def/define! [:EH :MSG :MATCH] + (fn [_thought parent] + (let [data (thought/data parent) + [to from] (map #(get-in data [:delegates %]) [(:to data) (:from data)]) + stages (for [a to b from] [:EH :IMPL a b]) + parent (assoc parent :ext-stages (vec stages))] + [parent nil]))) + +(defn apply-extensions [] + (run! #(apply apply-ext %) + [[[:EH :MSG :DEREF] [:EH :MSG :RESOLVE :DEREF]] + [[:EH :MSG :PARSE-NUM] [:EH :MSG :RESOLVE :PARSE]] + [[:EH :MSG :MATCH] [:EH :MSG :RESOLVE :MATCH]]])) + +(defn register-primitives [] + (run! thought/register-singleton! + [[:EH :MSG :DEREF] + [:EH :MSG :PARSE-NUM] + [:EH :MSG :MATCH] + [:EH :PRIM [:EH :PRIM :NUM] :+] + [:EH :PRIM :REIFY :+]])) + +(defn register-single-implementations [] + (run! #(apply register-single-impl %) + [[[:EH :PRIM :NUM] :+ [:EH :PRIM [:EH :PRIM :NUM] :+]]])) + +(register-primitives) +(apply-extensions) +(register-single-implementations) diff --git a/src/cljs/emptyhead/newlib/scratch.cljs b/src/cljs/emptyhead/newlib/scratch.cljs new file mode 100644 index 0000000..3fe2065 --- /dev/null +++ b/src/cljs/emptyhead/newlib/scratch.cljs @@ -0,0 +1,9 @@ +(ns emptyhead.newlib.scratch + "Scratch namespace for development." + (:require [emptyhead.newlib.message :as msg] + [emptyhead.newlib.delegate :as del] + [emptyhead.newlib.math.arithmetic] + [emptyhead.newlib.math.number])) + +;; XXX why does the second arg need to be wrapped like this? +(del/add-delegate :! [[:EH :PRIM :REIFY]]) diff --git a/src/cljs/emptyhead/thought/crud.cljs b/src/cljs/emptyhead/thought/crud.cljs index 416720f..a64ccc0 100644 --- a/src/cljs/emptyhead/thought/crud.cljs +++ b/src/cljs/emptyhead/thought/crud.cljs @@ -11,7 +11,7 @@ You may want `register-thought!` instead." [operator & {:keys [data ext-stages return transient] :or {data {} - ext-stages [[:PRE-EXECUTE] [:EXECUTE] [:POST-EXECUTE]] + ext-stages [] transient true return []}}] (hash-map :operator operator @@ -35,7 +35,7 @@ [operator] (prop/with-property (magic/operator-property [operator]))) -(defn deref-primitive +(defn get-singleton [operator] (let [existing (deref-primitive_ operator) n (count existing)] @@ -50,7 +50,7 @@ :as args}] (let [existing (deref-primitive_ operator)] (run! idea/forget-idea! existing) - (register-thought! operator args))) + (register-thought! operator (assoc args :transient false)))) (defn stages "Get the extension stages of a `thought`. diff --git a/src/cljs/emptyhead/thought/eval.cljs b/src/cljs/emptyhead/thought/eval.cljs index 1a029e1..450acc6 100644 --- a/src/cljs/emptyhead/thought/eval.cljs +++ b/src/cljs/emptyhead/thought/eval.cljs @@ -23,7 +23,7 @@ [thought & [parent]] (loop [parent (or parent (thought/make-thought [:EH :NOP])) th (prtc/val-fn #(assoc % :_parent (prtc/value parent)) thought)] - (let [[extensions th cur] (extend/pop-stage th) + (let [[extensions th _cur] (extend/pop-stage th) ;; Execute extensions, potentially modifying th th (reduce #(execute! %2 %1) th extensions) @@ -40,8 +40,8 @@ ;; Recur if there's remaining aspects, otherwise return `parent`. (if (not-empty (thought/stages th)) - (recur th parent) - (do - (when (prtc/val-fn :transient thought) - (prtc/ref-fn idea/forget-idea! thought)) - parent))))) + (recur parent th) + (do + (when (prtc/val-fn :transient thought) + (prtc/ref-fn idea/forget-idea! thought)) + parent)))))