|
219 | 219 | ([exp-seq equality-only-variables] |
220 | 220 |
|
221 | 221 | (if (empty? exp-seq) |
222 | | - `(deref ~'?__bindings__) |
| 222 | + '?__bindings__ |
223 | 223 | (let [[exp & rest-exp] exp-seq |
224 | 224 | variables (into #{} |
225 | 225 | (filter (fn [item] |
|
256 | 256 | ;; First assign each value in a let, so it is visible to subsequent expressions. |
257 | 257 | `(let [~@(for [variable variables |
258 | 258 | let-expression [variable (first expression-values)]] |
259 | | - let-expression)] |
260 | | - |
261 | | - ;; Update the bindings produced by this expression. |
262 | | - ~@(for [variable variables] |
263 | | - `(swap! ~'?__bindings__ assoc ~(keyword variable) ~variable)) |
| 259 | + let-expression) |
| 260 | + ;; Update the bindings produced by this expression. |
| 261 | + ;; intentional shadowing here of the ?__bindings__ variable with each newly |
| 262 | + ;; bound variables associated. |
| 263 | + ~'?__bindings__ (assoc ~'?__bindings__ ~@(mapcat (juxt keyword identity) variables))] |
264 | 264 |
|
265 | 265 | ;; If there is more than one expression value, we need to ensure they are |
266 | 266 | ;; equal as well as doing the bind. This ensures that value-1 and value-2 are |
|
371 | 371 | `(fn ~fn-name [~(add-meta '?__fact__ type) |
372 | 372 | ~destructured-env] |
373 | 373 | (let [~@assignments |
374 | | - ~'?__bindings__ (atom ~initial-bindings)] |
| 374 | + ~'?__bindings__ ~initial-bindings] |
375 | 375 | ~(compile-constraints constraints))))) |
376 | 376 |
|
377 | | -(defn build-token-assignment |
378 | | - "A helper function to build variable assignment forms for tokens." |
379 | | - [binding-key] |
380 | | - (list (symbol (name binding-key)) |
381 | | - (list `-> '?__token__ :bindings binding-key))) |
382 | | - |
383 | 377 | (defn compile-test-handler [node-id constraints env] |
384 | 378 | (let [binding-keys (variables-as-keywords constraints) |
385 | | - assignments (mapcat build-token-assignment binding-keys) |
386 | 379 |
|
387 | 380 | ;; The destructured environment, if any |
388 | 381 | destructured-env (if (> (count env) 0) |
|
392 | 385 | ;; Hardcoding the node-type and fn-type as we would only ever expect 'compile-test' to be used for this scenario |
393 | 386 | fn-name (mk-node-fn-name "TestNode" node-id "TE")] |
394 | 387 | `(fn ~fn-name [~'?__token__ ~destructured-env] |
395 | | - (let [~@assignments] |
396 | | - (and ~@constraints))))) |
| 388 | + ;; exceedingly unlikely that we'd have a test node without bound variables to be tested, |
| 389 | + ;; however since the contract is that of arbitrary clojure there is nothing preventing users |
| 390 | + ;; from defining tests that look outside the Session here. In such event, those without bound variables, |
| 391 | + ;; we can avoid the bindings entirely. |
| 392 | + ~(if (seq binding-keys) |
| 393 | + `(let [{:keys [~@(map (comp symbol name) binding-keys)]} (:bindings ~'?__token__)] |
| 394 | + (and ~@constraints)) |
| 395 | + `(and ~@constraints))))) |
397 | 396 |
|
398 | 397 | (defn compile-test [node-id constraints env] |
399 | | - (let [test-handler (compile-test-handler node-id constraints env)] |
400 | | - `(array-map :handler ~test-handler |
401 | | - :constraints '~constraints))) |
| 398 | + (compile-test-handler node-id constraints env)) |
402 | 399 |
|
403 | 400 | (defn compile-action-handler |
404 | | - [action-name bindings-keys rhs env] |
| 401 | + [action-name binding-keys rhs env] |
405 | 402 | (let [;; Avoid creating let bindings in the compile code that aren't actually used in the body. |
406 | 403 | ;; The bindings only exist in the scope of the RHS body, not in any code called by it, |
407 | 404 | ;; so this scanning strategy will detect all possible uses of binding variables in the RHS. |
408 | 405 | ;; Note that some strategies with macros could introduce bindings, but these aren't something |
409 | 406 | ;; we're trying to support. If necessary a user could macroexpand their RHS code manually before |
410 | 407 | ;; providing it to Clara. |
411 | 408 | rhs-bindings-used (variables-as-keywords rhs) |
412 | | - |
413 | | - assignments (sequence |
414 | | - (comp |
415 | | - (filter rhs-bindings-used) |
416 | | - (mapcat build-token-assignment)) |
417 | | - bindings-keys) |
| 409 | + token-binding-keys (sequence |
| 410 | + (filter rhs-bindings-used) |
| 411 | + binding-keys) |
418 | 412 |
|
419 | 413 | ;; The destructured environment, if any. |
420 | 414 | destructured-env (if (> (count env) 0) |
421 | | - {:keys (mapv (comp symbol name) (keys env))} |
| 415 | + {:keys (mapv #(symbol (name %)) (keys env))} |
422 | 416 | '?__env__)] |
423 | | - `(fn ~action-name |
424 | | - [~'?__token__ ~destructured-env] |
425 | | - (let [~@assignments] |
426 | | - ~rhs)))) |
| 417 | + `(fn ~action-name [~'?__token__ ~destructured-env] |
| 418 | + ;; similar to test nodes, nothing in the contract of an RHS enforces that bound variables must be used. |
| 419 | + ;; similarly we will not bind anything in this event, and thus the let block would be superfluous. |
| 420 | + ~(if (seq token-binding-keys) |
| 421 | + `(let [{:keys [~@(map (comp symbol name) token-binding-keys)]} (:bindings ~'?__token__)] |
| 422 | + ~rhs) |
| 423 | + rhs)))) |
427 | 424 |
|
428 | 425 | (defn compile-action |
429 | 426 | "Compile the right-hand-side action of a rule, returning a function to execute it." |
|
448 | 445 |
|
449 | 446 | (defn compile-join-filter |
450 | 447 | "Compiles to a predicate function that ensures the given items can be unified. Returns a ready-to-eval |
451 | | - function that accepts the following: |
| 448 | + function that accepts the following: |
452 | 449 |
|
453 | | - * a token from the parent node |
454 | | - * the fact |
455 | | - * a map of bindings from the fact, which was typically computed on the alpha side |
456 | | - * an environment |
| 450 | + * a token from the parent node |
| 451 | + * the fact |
| 452 | + * a map of bindings from the fact, which was typically computed on the alpha side |
| 453 | + * an environment |
457 | 454 |
|
458 | | - The function created here returns truthy if the given fact satisfies the criteria." |
| 455 | + The function created here returns truthy if the given fact satisfies the criteria." |
459 | 456 | [node-id node-type {:keys [type constraints args] :as unification-condition} ancestor-bindings element-bindings env] |
460 | 457 | (let [accessors (field-name->accessors-used type constraints) |
461 | 458 |
|
|
479 | 476 | ;; created element bindings for this condition removed. |
480 | 477 | token-binding-keys (remove element-bindings (variables-as-keywords constraints)) |
481 | 478 |
|
482 | | - token-assignments (mapcat build-token-assignment token-binding-keys) |
483 | | - |
484 | | - new-binding-assignments (mapcat #(list (symbol (name %)) |
485 | | - (list 'get '?__element-bindings__ %)) |
486 | | - element-bindings) |
487 | | - |
488 | | - assignments (concat |
489 | | - fact-assignments |
490 | | - token-assignments |
491 | | - new-binding-assignments) |
492 | | - |
493 | 479 | equality-only-variables (into #{} (for [binding ancestor-bindings] |
494 | 480 | (symbol (name (keyword binding))))) |
495 | 481 |
|
|
500 | 486 | ~(add-meta '?__fact__ type) |
501 | 487 | ~'?__element-bindings__ |
502 | 488 | ~destructured-env] |
503 | | - (let [~@assignments |
504 | | - ~'?__bindings__ (atom {})] |
| 489 | + (let [~@fact-assignments |
| 490 | + ;; We should always have some form of bound variables here, however in the event that we ever didn't |
| 491 | + ;; there would be no need to generate non-existent bindings. |
| 492 | + ~@(when (seq element-bindings) |
| 493 | + [{:keys (mapv (comp symbol name) element-bindings)} '?__element-bindings__]) |
| 494 | + ~@(when (seq token-binding-keys) |
| 495 | + [{:keys (mapv (comp symbol name) token-binding-keys)} (list :bindings '?__token__)]) |
| 496 | + ~'?__bindings__ {}] |
505 | 497 | ~(compile-constraints constraints equality-only-variables))))) |
506 | 498 |
|
507 | 499 | (defn- expr-type [expression] |
|
1613 | 1605 |
|
1614 | 1606 | (sc/defn ^:private compile-node |
1615 | 1607 | "Compiles a given node description into a node usable in the network with the |
1616 | | - given children." |
| 1608 | + given children." |
1617 | 1609 | [beta-node :- (sc/conditional |
1618 | 1610 | (comp #{:production :query} :node-type) schema/ProductionNode |
1619 | 1611 | :else schema/ConditionNode) |
|
1677 | 1669 | (eng/->TestNode |
1678 | 1670 | id |
1679 | 1671 | env |
| 1672 | + (:constraints condition) |
1680 | 1673 | (compiled-expr-fn id :test-expr) |
1681 | 1674 | children) |
1682 | 1675 |
|
|
1696 | 1689 | (if (:join-filter-expressions beta-node) |
1697 | 1690 | (eng/->AccumulateWithJoinFilterNode |
1698 | 1691 | id |
1699 | | - ;; Create an accumulator structure for use when examining the node or the tokens |
1700 | | - ;; it produces. |
| 1692 | + ;; Create an accumulator structure for use when examining the node or the tokens |
| 1693 | + ;; it produces. |
1701 | 1694 | {:accumulator (:accumulator beta-node) |
1702 | | - ;; Include the original filter expressions in the constraints for inspection tooling. |
| 1695 | + ;; Include the original filter expressions in the constraints for inspection tooling. |
1703 | 1696 | :from (update-in condition [:constraints] |
1704 | 1697 | into (-> beta-node :join-filter-expressions :constraints))} |
1705 | 1698 | compiled-accum |
|
1712 | 1705 | ;; All unification is based on equality, so just use the simple accumulate node. |
1713 | 1706 | (eng/->AccumulateNode |
1714 | 1707 | id |
1715 | | - ;; Create an accumulator structure for use when examining the node or the tokens |
1716 | | - ;; it produces. |
| 1708 | + ;; Create an accumulator structure for use when examining the node or the tokens |
| 1709 | + ;; it produces. |
1717 | 1710 | {:accumulator (:accumulator beta-node) |
1718 | 1711 | :from condition} |
1719 | 1712 | compiled-accum |
|
0 commit comments