Start implementing EH stdlib

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]))

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)))

src/cljs/emptyhead/newlib/lazy.cljs

@@ -0,0 +1 @@
+(ns emptyhead.newlib.lazy)

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)])))

src/cljs/emptyhead/newlib/math/number.cljs

@@ -0,0 +1,3 @@
+(ns emptyhead.newlib.math.number
+  (:require [emptyhead.thought.define :as def]))
+

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)

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]])

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`.

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)))))