more fixups to the datomic code

src/mjolnir/ssa.clj

@@ -93,20 +93,37 @@
 (defn new-plan [conn]
   (->TxPlan conn (db conn) {} {} {}))
 
-(defn commit [{:keys [conn db new-ents]}]
-  (d/transact conn (map
-                    (fn [[ent id]]
-                      (assoc ent :db/id id))
-                    new-ents)))
+(defn commit
+  "Commit processes the transaction with the associated connection, then updates all the tempids to match. You can then use plan-id to get the realized ent-ids"
+  [{:keys [conn db new-ents] :as plan}]
+  (let [data (map
+              (fn [[ent id]]
+                (assoc ent :db/id id))
+              new-ents)
+        {:keys [db-before db-after tempids tx-data]}
+        @(d/transact conn data)
+        ptempids (zipmap
+                  (keys (:tempids plan))
+                  (map (partial d/resolve-tempid db-after tempids)
+                       (vals (:tempids plan))))]
+    (assoc plan
+      :tempids ptempids
+      :db db-after
+      :db-before db-before
+      :new-ents nil
+      :singletons nil)))
 
 (defn plan-id 
   [plan val]
-  (if-let [v (or (get-in plan [:singletons val])
-                   (get-in plan [:new-ents val]))]
+  (if-let [v (get-in plan [:tempids val])]
     v
     (assert false (str "Can't find " val))))
 
-(defn singleton [plan sing]
+(defn plan-ent
+  [plan val]
+  (d/entity (:db plan) (get-in plan [:tempids val])))
+
+(defn singleton [plan sing key]
   (if (get-in plan [:singletons sing])
     plan
     (if-let [q (find-singleton (:db plan) sing)]
@@ -115,54 +132,30 @@
         (-> plan
             (assoc-in [:singletons sing] newid)
             (assoc-in [:new-ents sing] newid)
-            (assoc-in [:tempids newid] nil))))))
+            (assoc-in [:tempids key] newid))))))
 
-(defn assert-entity [plan ent]
+(defn assert-entity [plan ent key]
   (let [newid (d/tempid :db.part/user)]
         (-> plan
             (assoc-in [:new-ents ent] nil)
-            (assoc-in [:tempids newid] nil))))
-
-
-(defn transact-new [conn ent]
-  (let [ent (if-not (:db/id ent)
-              (assoc ent :db/id (d/tempid :db.part/user))
-              ent)
-        {:keys [db-after tempids]} @(d/transact conn [ent])
-        tid (:db/id ent)]
-    (->> (d/resolve-tempid db-after tempids tid)
-         (d/entity db-after))))
-
-(defn transact-singleton [conn sing]
-  (let [genq (get-query sing)]
-    (println genq "\n " sing "\n \n")
-    (if-let [id (ffirst (q genq
-                         (db conn)))]
-      (d/entity (db conn) id)
-      (transact-new conn sing))))
-
-(defn transact-seq [conn seq]
-  (reduce (fn [acc x]
-            (transact-singleton
-             conn
-             (merge
-              (if-let [id (:db/id acc)]
-                {:list/tail id}
-                {})
-              {:list/head x})))
-          {}
+            (assoc-in [:tempids key] newid))))
+
+(defn- assert-node [[plan last] id]
+  (let [ent (merge
+             (if last
+               {:list/tail last}
+               {})
+             {:list/head id})
+        new-plan (singleton plan ent ent)
+        new-id (plan-id new-plan ent)]
+    [new-plan new-id]))
+
+(defn assert-seq [plan seq]
+  (reduce assert-node
+          [plan nil]
           (reverse seq)))
 
 
-(defn new-block [conn fn]
-  (transact-new ))
-
-
-(defn to-seq [e]
-  (when-not (nil? e)
-    (cons (:list/head e)
-          (lazy-seq (to-seq (:list/tail e))))))
-
 (defn new-db []
   (let [url (str "datomic:mem://ssa" (name (gensym)))]
     (d/create-database url)

src/mjolnir/types.clj

@@ -66,7 +66,8 @@
     (-> plan
         (singleton
           {:node/type :type.int
-           :type/width width}))))
+           :type/width width}
+          this))))
 
 
 (defrecord VoidType []
@@ -97,7 +98,8 @@
     (singleton
      plan
      {:node/type :type.float
-      :type/width width})))
+      :type/width width}
+     this)))
 
 (defn float-type? [tp]
   (instance? FloatType tp))
@@ -134,7 +136,8 @@
       (singleton
        with-tp
        {:node/type :type.pointer
-        :type/element-type (plan-id with-tp etype)}))))
+        :type/element-type (plan-id with-tp etype)}
+       this))))
 
 
 
@@ -190,12 +193,15 @@
     (let [with-types (reduce
                       add-to-plan
                       plan
-                      (cons ret-type arg-types))]
-      (singleton with-types
+                      (cons ret-type arg-types))
+          [with-seq arg-id] (assert-seq with-types
+                                        (map (partial plan-id with-types)
+                                             arg-types))]
+      (singleton with-seq
                  {:node/type :type.fn
-                  :type.fn/return (plan-id with-types ret-type)
-                  :type.fn/arguments (map (partial plan-id with-types)
-                                          arg-types)}))))
+                  :type.fn/return (plan-id with-seq ret-type)
+                  :type.fn/arguments arg-id}
+                 this))))
 
 
 (defn flatten-struct [tp]

test/mjolnir/ssa_test.clj

@@ -78,54 +78,59 @@
           count)
       =>
       2
-      )
-    #_(fact "IntegerType will re-assert different widths"
-      (to-datoms Float64*) =not=> (to-datoms Float32*))
-    #_(fact "Element type matches"
-      (:type/element-type (to-datoms Float64*)) => (to-datoms Float64)))
+      ))
 
-  #_(let [ft (->FunctionType [Float64 Int64] Int64)]
+  (let [ft (->FunctionType [Float64 Int64] Int64)]
     (facts "FunctionType"
       (fact "FunctionType is singleton"
-        (to-datoms ft) => (to-datoms ft))
-      (fact "Functions have proper return types"
-        (:type.fn/return (to-datoms ft))
-        =>
-        (to-datoms Int64))
-      (fact "Functions have proper arguments"
-        (to-seq (:type.fn/arguments (to-datoms ft)))
+        (-> (new-plan *db-conn*)
+            (add-to-plan ft)
+            (add-to-plan ft)
+            :new-ents
+            count)
         =>
-        [(to-datoms Float64)
-         (to-datoms Int64)])))
+        5)
+      (fact "Functions have proper return types"
+        (let [plan (-> (new-plan *db-conn*)
+                       (add-to-plan ft)
+                       commit)]
+          (:type.fn/return (plan-ent plan ft))
+          =>
+          (plan-ent plan Int64)))
+      #_(fact "Functions have proper arguments"
+          (to-seq (:type.fn/arguments (to-datoms ft)))
+          =>
+          [(to-datoms Float64)
+           (to-datoms Int64)])))
 
   #_(let [ft (->FunctionType [Int64] Int64)
-        f (->Fn "ret0" ft ["a" "b"]
-                0)]
-    (facts "Fn"
-      (fact "Functions create new entities each time"
-        (to-datoms f)
-        =not=>
-        (to-datoms f))
-      (fact "Functions with the same types are the same types"
-        (:fn/type (to-datoms f))
-        =>
-        (:fn/type (to-datoms f)))
-      (fact "Functions assert names"
-        (->> (to-datoms f)
-             :fn/argument-names
-             to-seq
-             (map :argument/name))
-        =>
-        ["a" "b"])
-      (fact "Functions assert indexes"
-        (->> (to-datoms f)
-             :fn/argument-names
-             to-seq
-             (map :argument/idx))
-        =>
-        [0 1])))
+          f (->Fn "ret0" ft ["a" "b"]
+                  0)]
+      (facts "Fn"
+        (fact "Functions create new entities each time"
+          (to-datoms f)
+          =not=>
+          (to-datoms f))
+        (fact "Functions with the same types are the same types"
+          (:fn/type (to-datoms f))
+          =>
+          (:fn/type (to-datoms f)))
+        (fact "Functions assert names"
+          (->> (to-datoms f)
+               :fn/argument-names
+               to-seq
+               (map :argument/name))
+          =>
+          ["a" "b"])
+        (fact "Functions assert indexes"
+          (->> (to-datoms f)
+               :fn/argument-names
+               to-seq
+               (map :argument/idx))
+          =>
+          [0 1])))
   #_(facts "Long"
-    (fact "Can be transacted"
-      (:const/int-value (to-datoms 0))
-      =>
-      0)))
+      (fact "Can be transacted"
+        (:const/int-value (to-datoms 0))
+        =>
+        0)))