Skip to content

Commit

Permalink
Initial pass at session and working memory state durability for issue…
Browse files Browse the repository at this point in the history 
… 198
  • Loading branch information
MR027750 committed Aug 31, 2016
1 parent a018de7 commit f7a0773
Show file tree
Hide file tree
Showing 7 changed files with 1,677 additions and 433 deletions.
3 changes: 2 additions & 1 deletion project.clj
View file
Original file line number Diff line number Diff line change
Expand Up @@ -5,7 +5,8 @@
:url "http://www.eclipse.org/legal/epl-v10.html"}
:dependencies [[org.clojure/clojure "1.7.0"]
[prismatic/schema "1.0.1"]]
:profiles {:dev {:dependencies [[org.clojure/math.combinatorics "0.1.3"]]}
:profiles {:dev {:dependencies [[org.clojure/math.combinatorics "0.1.3"]
[org.clojure/data.fressian "0.2.1"]]}
:provided {:dependencies [[org.clojure/clojurescript "1.7.170"]]}}
:plugins [[lein-codox "0.9.0" :exclusions [org.clojure/clojure]]
[lein-javadoc "0.2.0" :exclusions [org.clojure/clojure]]
Expand Down
268 changes: 160 additions & 108 deletions src/main/clojure/clara/rules/compiler.clj
View file
Original file line number Diff line number Diff line change
Expand Up @@ -14,19 +14,42 @@
[clojure.walk :as walk]
[schema.core :as sc]
[schema.macros :as sm])

(:import [clara.rules.engine ProductionNode QueryNode HashJoinNode ExpressionJoinNode
NegationNode TestNode AccumulateNode AlphaNode LocalTransport
LocalSession Accumulator]
[java.beans PropertyDescriptor]))
(:import [clara.rules.engine
ProductionNode
QueryNode
AlphaNode
RootJoinNode
HashJoinNode
ExpressionJoinNode
NegationNode
NegationWithJoinFilterNode
TestNode
AccumulateNode
AccumulateWithJoinFilterNode
LocalTransport
LocalSession
Accumulator]
[java.beans
PropertyDescriptor]))

;; Protocol for loading rules from some arbitrary source.
(defprotocol IRuleSource
(load-rules [source]))

;; These nodes exist in the beta network.
(def BetaNode (sc/either ProductionNode QueryNode HashJoinNode ExpressionJoinNode
NegationNode TestNode AccumulateNode))
(sc/defschema BetaNode
"These nodes exist in the beta network."
(sc/pred (comp #{ProductionNode
QueryNode
RootJoinNode
HashJoinNode
ExpressionJoinNode
NegationNode
NegationWithJoinFilterNode
TestNode
AccumulateNode
AccumulateWithJoinFilterNode}
class)
"Some beta node type"))

;; A rulebase -- essentially an immutable Rete network with a collection of
;; alpha and beta nodes and supporting structure.
Expand Down Expand Up @@ -182,7 +205,7 @@

(def ^:dynamic *compile-ctx* nil)

(defn- try-eval
(defn try-eval
"Evals the given `expr`. If an exception is thrown, it is caught and an
ex-info exception is thrown with more details added. Uses *compile-ctx*
for additional contextual info to add to the exception details."
Expand Down Expand Up @@ -1177,22 +1200,26 @@
condition
children
join-bindings)

;; If the join operation includes arbitrary expressions
;; that can't expressed as a hash join, we must use the expressions
(if (:join-filter-expressions beta-node)
(eng/->ExpressionJoinNode
id
condition
(binding [*compile-ctx* {:condition condition
:join-filter-expressions (:join-filter-expressions beta-node)
:env (:env beta-node)
:msg "compiling expression join node"}]
(compile-expr id
(compile-join-filter (:join-filter-expressions beta-node)
(:join-filter-join-bindings beta-node)
(:env beta-node))))
children
join-bindings)
(let [join-filter-expr (compile-join-filter (:join-filter-expressions beta-node)
(:join-filter-join-bindings beta-node)
(:env beta-node))]
(with-meta
(eng/->ExpressionJoinNode
id
condition
(binding [*compile-ctx* {:condition condition
:join-filter-expressions (:join-filter-expressions beta-node)
:env (:env beta-node)
:msg "compiling expression join node"}]
(compile-expr id
join-filter-expr))
children
join-bindings)
{:join-filter-expr join-filter-expr}))
(eng/->HashJoinNode
id
condition
Expand All @@ -1205,19 +1232,22 @@
;; and use the appropriate node type.
(if (:join-filter-expressions beta-node)

(eng/->NegationWithJoinFilterNode
id
condition
(binding [*compile-ctx* {:condition condition
:join-filter-expressions (:join-filter-expressions beta-node)
:env (:env beta-node)
:msg "compiling negation with join filter node"}]
(compile-expr id
(compile-join-filter (:join-filter-expressions beta-node)
(:join-filter-join-bindings beta-node)
(:env beta-node))))
children
join-bindings)
(let [join-filter-expr (compile-join-filter (:join-filter-expressions beta-node)
(:join-filter-join-bindings beta-node)
(:env beta-node))]
(with-meta
(eng/->NegationWithJoinFilterNode
id
condition
(binding [*compile-ctx* {:condition condition
:join-filter-expressions (:join-filter-expressions beta-node)
:env (:env beta-node)
:msg "compiling negation with join filter node"}]
(compile-expr id
join-filter-expr))
children
join-bindings)
{:join-filter-expr join-filter-expr}))

(eng/->NegationNode
id
Expand All @@ -1226,24 +1256,28 @@
join-bindings))

:test
(eng/->TestNode
id
(binding [*compile-ctx* {:condition condition
:env (:env beta-node)
:msg "compiling test node"}]
(compile-expr id
(compile-test (:constraints condition))))
children)
(let [test-expr (compile-test (:constraints condition))]
(with-meta
(eng/->TestNode
id
(binding [*compile-ctx* {:condition condition
:env (:env beta-node)
:msg "compiling test node"}]
(compile-expr id
test-expr))
children)
{:test-expr test-expr}))

:accumulator
;; We create an accumulator that accepts the environment for the beta node
;; into its context, hence the function with the given environment.
(let [compiled-node (binding [*compile-ctx* {:condition condition
(let [accum-expr (compile-accum (:accumulator beta-node) (:env beta-node))
compiled-node (binding [*compile-ctx* {:condition condition
:accumulator (:accumulator beta-node)
:env (:env beta-node)
:msg "compiling accumulator"}]
(compile-expr id
(compile-accum (:accumulator beta-node) (:env beta-node))))
accum-expr))
compiled-accum (compiled-node (:env beta-node))]

;; Ensure the compiled accumulator has the expected structure
Expand All @@ -1255,54 +1289,63 @@

(if (:join-filter-expressions beta-node)

(eng/->AccumulateWithJoinFilterNode
id
;; Create an accumulator structure for use when examining the node or the tokens
;; it produces.
{:accumulator (:accumulator beta-node)
;; Include the original filter expressions in the constraints for inspection tooling.
:from (update-in condition [:constraints]
into (-> beta-node :join-filter-expressions :constraints))}
compiled-accum
(binding [*compile-ctx* {:condition condition
:join-filter-expressions (:join-filter-expressions beta-node)
:env (:env beta-node)
:msg "compiling accumulate with join filter node"}]
(compile-expr id
(compile-join-filter (:join-filter-expressions beta-node)
(:join-filter-join-bindings beta-node)
(:env beta-node))))
(:result-binding beta-node)
children
join-bindings
(:new-bindings beta-node))
(let [join-filter-expr (compile-join-filter (:join-filter-expressions beta-node)
(:join-filter-join-bindings beta-node)
(:env beta-node))]
(with-meta
(eng/->AccumulateWithJoinFilterNode
id
;; Create an accumulator structure for use when examining the node or the tokens
;; it produces.
{:accumulator (:accumulator beta-node)
;; Include the original filter expressions in the constraints for inspection tooling.
:from (update-in condition [:constraints]
into (-> beta-node :join-filter-expressions :constraints))}
compiled-accum
(binding [*compile-ctx* {:condition condition
:join-filter-expressions (:join-filter-expressions beta-node)
:env (:env beta-node)
:msg "compiling accumulate with join filter node"}]
(compile-expr id
join-filter-expr))
(:result-binding beta-node)
children
join-bindings
(:new-bindings beta-node))
{:accum-expr accum-expr
:join-filter-expr join-filter-expr}))

;; All unification is based on equality, so just use the simple accumulate node.
(eng/->AccumulateNode
id
;; Create an accumulator structure for use when examining the node or the tokens
;; it produces.
{:accumulator (:accumulator beta-node)
:from condition}
compiled-accum
(:result-binding beta-node)
children
join-bindings
(:new-bindings beta-node))))
(with-meta
(eng/->AccumulateNode
id
;; Create an accumulator structure for use when examining the node or the tokens
;; it produces.
{:accumulator (:accumulator beta-node)
:from condition}
compiled-accum
(:result-binding beta-node)
children
join-bindings
(:new-bindings beta-node))
{:accum-expr accum-expr})))

:production
(eng/->ProductionNode
id
production
(with-bindings (cond-> {#'*file* (-> production :rhs meta :file)
#'*compile-ctx* {:production production
:msg "compiling production node"}}
(:ns-name production) (assoc #'*ns* (the-ns (:ns-name production))))
(compile-expr id
(with-meta (compile-action (:bindings beta-node)
(:rhs production)
(:env production))
(meta (:rhs production))))))
(let [action-expr (with-meta (compile-action (:bindings beta-node)
(:rhs production)
(:env production))
(meta (:rhs production)))]
(with-meta
(eng/->ProductionNode
id
production
(with-bindings (cond-> {#'*file* (-> production :rhs meta :file)
#'*compile-ctx* {:production production
:msg "compiling production node"}}
(:ns-name production) (assoc #'*ns* (the-ns (:ns-name production))))
(compile-expr id
action-expr)))
{:action-expr action-expr}))

:query
(eng/->QueryNode
Expand Down Expand Up @@ -1421,19 +1464,22 @@
[alpha-nodes :- [schema/AlphaNode]]
(for [{:keys [condition beta-children env]} alpha-nodes
:let [{:keys [type constraints fact-binding args]} condition
cmeta (meta condition)]]

(cond-> {:type (effective-type type)
:alpha-fn (binding [*file* (or (:file cmeta) *file*)
*compile-ctx* {:condition condition
:env env
:msg "compiling alpha node"}]
(try-eval (with-meta (compile-condition
type (first args) constraints
fact-binding env)
(meta condition))))
:children beta-children}
env (assoc :env env))))
cmeta (meta condition)
alpha-expr (with-meta (compile-condition
type (first args) constraints
fact-binding env)
(meta condition))]]

(with-meta
(cond-> {:type (effective-type type)
:alpha-fn (binding [*file* (or (:file cmeta) *file*)
*compile-ctx* {:condition condition
:env env
:msg "compiling alpha node"}]
(try-eval alpha-expr))
:children beta-children}
env (assoc :env env))
{:alpha-expr alpha-expr})))

(sc/defn build-network
"Constructs the network from compiled beta tree and condition functions."
Expand All @@ -1460,9 +1506,11 @@
entry))

;; type, alpha node tuples.
alpha-nodes (for [{:keys [type alpha-fn children env]} alpha-fns
alpha-nodes (for [{:keys [type alpha-fn children env] :as alpha-map} alpha-fns
:let [beta-children (map id-to-node children)]]
[type (eng/->AlphaNode env beta-children alpha-fn)])
[type (with-meta
(eng/->AlphaNode env beta-children alpha-fn)
{:alpha-expr (:alpha-expr (meta alpha-map))})])

;; Merge the alpha nodes into a multi-map
alpha-map (reduce
Expand Down Expand Up @@ -1540,6 +1588,10 @@
[]
(reset! session-cache {}))

(defn production-load-order-comp [a b]
(< (-> a meta ::rule-load-order)
(-> b meta ::rule-load-order)))

(sc/defn mk-session*
"Compile the rules into a rete network and return the given session."
[productions :- #{schema/Production}
Expand All @@ -1553,10 +1605,10 @@
;;
;; Note that this ordering is not for correctness; we are just trying to increase consistency of rulebase compilation,
;; and hopefully thereby execution times, from run to run.
productions (into (sorted-set-by (fn [a b]
(< (-> a meta ::rule-load-order)
(-> b meta ::rule-load-order))))
productions)
productions (with-meta (into (sorted-set-by production-load-order-comp)
productions)
;; Store the name of the custom comparator for durability.
{:clara.rules.durability/comparator-name `production-load-order-comp})
beta-graph (to-beta-graph productions)
beta-tree (compile-beta-graph beta-graph)
beta-root-ids (-> beta-graph :forward-edges (get 0)) ; 0 is the id of the virtual root node.
Expand Down
Loading

0 comments on commit f7a0773

Please sign in to comment.