merge something

src/cljs/emptyhead/lib/core.cljs

@@ -17,11 +17,7 @@
 
 (def/define! [:emptyhead :core :return]
   (fn [thought parent]
-    [parent (thought/data thought)])
-  :constr-fn
-  (fn [thought parent]
-    (let [[_ data] (thought/pop-stack parent)]
-      {:data data})))
+    [parent (thought/data thought)]))
 
 (def/define! [:emptyhead :core :nop]
   (fn [thought parent]

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

@@ -3,30 +3,55 @@
   Since thoughts are ideas, 'missing' operations here are implemented in [[emptyhead.idea.crud]]."
   (:require [emptyhead.idea.protocol :as prtc]
             [emptyhead.idea.crud :as idea]
-            [emptyhead.util.magic :as magic]))
+            [emptyhead.util.magic :as magic]
+            [emptyhead.idea.property :as prop]))
 
 (defn make-thought
   "Helper function to make thought object.
   You may want `register-thought!` instead."
-  [operator & {:keys [data ext-stages return]
+  [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
             :data data
             :ext-stages ext-stages
+            :transient transient
             :return return))
 
 (defn register-thought!
   "Create a thought and register it in the state.
   Returns a reference to the created thought."
-  [operator & {:keys [data ext-stages]
+  [operator & {:keys [data ext-stages return transient]
                :as args}]
   (idea/have-idea!
    :prefix (str "emptyhead.thought#" (magic/symbolize-ns operator))
-   :properties [magic/thought-ns]
+   :properties [magic/thought-ns
+                (magic/operator-property [operator])]
    :data (make-thought operator args)))
 
+(defn deref-primitive_
+  [operator]
+  (prop/with-property (magic/operator-property [operator])))
+
+(defn get-singleton
+  [operator]
+  (let [existing (deref-primitive_ operator)
+        n (count existing)]
+    (when (> n 1)
+      (throw (ex-info (str "ERROR: Primitive " operator " has " n " implementations.")
+                      {:n n :operator operator})))
+  (first existing)))
+
+(defn register-singleton!
+  "Register a thought of which only one is meant to exist."
+  [operator & {:keys [data ext-stages]
+               :as args}]
+  (let [existing (deref-primitive_ operator)]
+    (run! idea/forget-idea! existing)
+    (register-thought! operator (assoc args :transient false))))
+
 (defn stages
   "Get the extension stages of a `thought`.
   Returns the list of stages."
@@ -52,6 +77,20 @@
   [thought]
   [(assoc thought :return (-> thought prtc/copy stack butlast vec)) (-> thought prtc/copy stack peek)])
 
+(defn empty-stack
+  [thought]
+  [(assoc thought :return []) (:return thought)])
+
+(defn pop-args
+  [thought dest]
+  (let [sentinel (into [:_FOR] (prtc/val-fn :operator dest))
+        stack (prtc/val-fn :return thought)
+        idx (.lastIndexOf stack sentinel)
+        before (subvec stack 0 idx)
+        after (subvec stack (+ 1 idx))]
+    [(assoc thought :return before)
+     after]))
+
 (defn add-ext-stage!
   [thought stage]
   (idea/mutate-idea! #(update % :ext-stages conj stage) thought))

src/cljs/emptyhead/thought/eval.cljs

@@ -6,6 +6,7 @@
             [emptyhead.util.logging :as logging]
             [emptyhead.thought.return :as return]
             [emptyhead.idea.property :as prop]
+            [emptyhead.idea.crud :as idea]
             [emptyhead.util.magic :as magic]))
 
 (defn- impl! [thought & [parent]]
@@ -16,15 +17,13 @@
                      {:thought thought :parent parent :type :unimplemented-thought})
       ((prtc/val-fn :implementation impl-idea) thought parent))))
 
-;; FIXME I don't think omitting the parent here is actually valid?
-;; might need to use thought.crud/root-thought, but better making parent mandatory tabun
 (defn execute!
   "Execute `thought` with `parent`, applying aspects to `thought` according to its :extension-stages.
   Returns (potentially modified) `parent`."
   [thought & [parent]]
-  (loop [th (prtc/val-fn #(assoc % :_parent (prtc/value parent)) thought)
-         parent parent]
-    (let [[extensions th cur] (extend/pop-stage th)
+  (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)
 
           ;; Execute extensions, potentially modifying th
           th (reduce #(execute! %2 %1) th extensions)
@@ -41,5 +40,8 @@
 
       ;; Recur if there's remaining aspects, otherwise return `parent`.
       (if (not-empty (thought/stages th))
-        (recur th parent)
-        parent))))
+        (recur parent th)
+         (do
+           (when (prtc/val-fn :transient thought)
+             (prtc/ref-fn idea/forget-idea! thought))
+           parent)))))

src/cljs/emptyhead/thought/return.cljs

@@ -11,6 +11,10 @@
      #(update % :return (fnil into []) data) thought)
     thought))
 
+(defn update-return
+  [thought fn]
+  (prtc/val-fn #(update-in % [:return] fn) thought))
+
 (defn return-vals [thought namespace]
   (prtc/val-fn #(get-in % [:return namespace]) thought))
 

src/cljs/emptyhead/util/magic.cljs

@@ -2,7 +2,11 @@
   "Magic values for EmptyHead."
   (:require [clojure.string :as str]))
 
-(def thought-ns [:emptyhead :thought])
+(def thought-ns [:EH :THOUGHT])
+
+(defn operator-property
+  [op]
+  (into [:EH :OPERATOR] op))
 
 (def thought-impl-ns (conj thought-ns :implementation))
 
@@ -15,4 +19,9 @@
   (conj extension-ns stage))
 
 (defn symbolize-ns [ns]
-  (str/join "." (map name ns)))
+  (str/join
+   "." (map
+        #(if (sequential? %)
+           (symbolize-ns (concat [:<] % [:>]))
+           (name %))
+        ns)))