syndicate-lang
/
syndicate-rkt
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

New dataspace pattern language.

This commit is contained in:
Tony Garnock-Jones 2024-04-09 14:00:33 +02:00
parent 0370c19e43
commit 9a0697e3c5
8 changed files with 459 additions and 295 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

477
syndicate/HOWITWORKS.md
View File

@ -1,7 +1,7 @@
# Efficient, Imperative Dataspaces for Conversational Concurrency # Efficient, Imperative Dataspaces for Conversational Concurrency
Tony Garnock-Jones <tonyg@leastfixedpoint.com> Tony Garnock-Jones <tonyg@leastfixedpoint.com>
20 October 2018; revised 21 June 2019 20 October 2018; revised 21 June 2019 and 4-5 April 2024
<p style="font-size:90%"><strong>Abstract.</strong> The dataspace <p style="font-size:90%"><strong>Abstract.</strong> The dataspace
model of Conversational Concurrency [is great], but implementing it model of Conversational Concurrency [is great], but implementing it
@ -29,7 +29,7 @@ language.
x ∈ identifiers X x ∈ identifiers X
a ∈ atoms A = numbers ∪ strings ∪ ... a ∈ atoms A = numbers ∪ strings ∪ ...
Here are some examples of assertions in `c`, along with suggested Here are some examples of assertions in `C`, along with suggested
interpretations: interpretations:
present("Alice") Alice is present in the chat room present("Alice") Alice is present in the chat room
@ -87,7 +87,7 @@ only the name of the speaker.
Imagine now an enriched version of our language that can construct Imagine now an enriched version of our language that can construct
patterns over data, including captures and "don't care" positions. patterns over data, including captures and "don't care" positions.
p ∈ patterns P ::= e | x(p, ...) | $x | _ p ∈ patterns P ::= v | x(p, ...) | $x | _
Syntactic patterns can be translated into assertions of interest Syntactic patterns can be translated into assertions of interest
directly. Binding subpatterns `$x` are translated into `capture()`, directly. Binding subpatterns `$x` are translated into `capture()`,
@ -113,10 +113,9 @@ event handlers added later.
### Skeletons ### Skeletons
A skeleton is comprised of three pieces: a *shape*, describing the A skeleton is comprised of three pieces: a *shape*, describing the
positions and arities of statically-known constructors in matching positions of statically-known constructors in matching assertions; a
assertions; a *constant map*, which places restrictions on fields *constant map*, which places restrictions on fields within constructors;
within constructors; and a *capture map*, which specifies locations of and a *capture map*, which specifies locations of captured positions.
captured positions.
Each time an assertion is added or removed, it is conceptually checked Each time an assertion is added or removed, it is conceptually checked
against each handler's skeleton. First, the overall shape is checked. against each handler's skeleton. First, the overall shape is checked.
@ -124,49 +123,57 @@ If the assertion passes this check, the constant map is checked. If
all the constants match, the capture map is used to prepare an all the constants match, the capture map is used to prepare an
argument vector, and the event handler's callback is invoked. argument vector, and the event handler's callback is invoked.
k ∈ skeletons K = S × [H×E] × [H] k ∈ skeletons K = S × (H ⟼ V+1) × [H]
s ∈ shapes S ::= * | x(s, ...) s ∈ shapes S = (H ⟼ L)
h ∈ paths H = [𝐍] ℓ ∈ classes L = X -- label
h ∈ paths H = [𝐍]
Shapes retain only statically-known constructors and arities in a Shapes retain only statically-known constructors in a pattern:
pattern:
shape :: P -> S shape :: P → S
shape e = * shape p = shape' [] p
shape x(p, ...) = x(shape p, ...) where
shape $x = * shape' :: H → P → S
shape _ = * shape h v = ∅
shape h x(p₀, ..., pᵢ) = (h ⟼ x)
∪ (shape (h++[0]) p₀) ∪ ...
∪ (shape (h++[i]) pᵢ)
shape h $x = ∅
shape h _ = ∅
A constant map extracts all non-capturing, non-discard positions in a A constant map filters potential matches by placing constraints on
pattern. The expressions in the map are evaluated at the time the contained fields. The paths `H` in the map denote positions to be
corresponding event handler is installed; that is, at facet creation checked; the predicates `V+1` denote either a particular value that must
time. They are not subsequently reevaluated; if any expression depends exist at that position, or a simple check that the term in question
on a dataflow variable, and that variable changes, the entire handler merely *has* a value in that position.
is removed, reevaluated, and reinstalled.
constantmap :: P -> [(H, E)] constantmap :: P → (H ⟼ V+1)
constantmap p = cmap [] p constantmap p = cmap [] p
where where
cmap :: H -> P -> [(H, E)] cmap :: H → P → (H ⟼ V+1)
cmap h e = [(h, e)] cmap h v = (h ⟼ inl v)
cmap h x(p_0, ..., p_i) = (cmap (h++[0]) p_0) ++ cmap h x(p₀, ..., pᵢ) = (cmap (h++[0]) p₀) ∪ ...
... ++ ∪ (cmap (h++[i]) pᵢ)
(cmap (h++[i]) p_i) cmap h $x = ∅
cmap h $x = [] cmap h _ = (h ⟼ inr ())
cmap h _ = []
Finally, a capture map extracts all capturing positions in a pattern: It will be useful to separate value-check operations from existence-check operations.
capturemap :: P -> [H] constantchecks :: (H ⟼ V+1) → (H ⟼ V) × 𝒫(H)
constantchecks m = ( { h ⟼ v | h ⟼ inl v ∈ m },
{ h | h ⟼ inr () ∈ m } )
Finally, a capture map extracts all capturing positions in a pattern.
capturemap :: P → [H]
capturemap p = vmap [] p capturemap p = vmap [] p
where where
vmap :: H -> P -> [H] vmap :: H → P → [H]
vmap h e = [] vmap h v = []
vmap h x(p_0, ..., p_i) = (vmap (h++[0]) p_0) ++ vmap h x(p₀, ..., pᵢ) = (vmap (h++[0]) p₀) ++ ...
... + ++ (vmap (h++[i]) pᵢ)
(vmap (h++[i]) p_i) vmap h $x = [h]
vmap h $x = [h] vmap h _ = []
vmap h _ = []
### The index ### The index
@ -175,8 +182,8 @@ assertion in the dataspace.
#### Overview and structures #### Overview and structures
An index is a pair of a bag of all currently-asserted An index contains a bag of all currently-asserted
assertion-values, plus the root node of a trie-like structure. assertion-values, as well as the root of a trie-like structure.
Information from each indexed event handler's skeleton's shape is laid Information from each indexed event handler's skeleton's shape is laid
out along edges connecting trie nodes. out along edges connecting trie nodes.
@ -185,23 +192,22 @@ a skeleton's constant map and capture map alongside handler callback
functions and caches of currently-asserted values. functions and caches of currently-asserted values.
Index = Bag(V) × Node Index = Bag(V) × Node
Node = Continuation × (Selector ⟼ Class ⟼ Node) Node = Continuation × (Move ⟼ L ⟼ Node)
Selector = 𝐍 × 𝐍 -- pop-count and index Move = 𝐍 × H
Class = X -- label
Continuation = 𝒫(V) × ([H] ⟼ [V] ⟼ Leaf) Continuation = 𝒫(V) × ([H]×𝒫(H) ⟼ [V] ⟼ Leaf)
Leaf = 𝒫(V) × ([H] ⟼ Handler) Leaf = 𝒫(V) × ([H] ⟼ Handler)
Handler = Bag([V]) × 𝒫(Callback) Handler = Bag([V]) × 𝒫(Callback)
Callback = EventType -> [V] -> V Callback = EventType → [V] → V
EventType ::= "+" | "-" | "!" EventType ::= "+" | "-" | "!"
Bag(τ) = τ ⟼ 𝐍 -- bag of τ values Bag(τ) = τ ⟼ 𝐍 -- bag of τ values
To use an index in the context of a single assertion—be it a new To use an index in the context of a single assertion—be it a new
addition, a removal, or a message to be delivered—follow a path from addition, a removal, or a message to be delivered—follow a path from
the root `Node` of the index along `Selector`/`Class`-labelled edges, the root `Node` of the index along move- and class-labelled edges,
collecting `Continuations` as you go. This yields a complete set of collecting `Continuations` as you go. This yields a complete set of
event handlers that may match the assertion being considered. Further event handlers that may match the assertion being considered. Further
investigating each collected `Continuation` by analyzing its constant investigating each collected `Continuation` by analyzing its constant
@ -213,15 +219,103 @@ At every `Continuation`, `Leaf` and `Handler` object, the index
maintains a set of currently-asserted values that conform to the maintains a set of currently-asserted values that conform to the
constraints implied by the object's position in the overall index. constraints implied by the object's position in the overall index.
Most of the components in an index are *mutable*: the `Bag(V)` in the Most of the components in an index are *mutable*: the `Bag(V)` and
initial class-to-`Node` map in the
root; the assertion-value cache set in each `Continuation` or `Leaf` root; the assertion-value cache set in each `Continuation` or `Leaf`
object; the map from `Selector` to `Class` to `Node` within each object; the map from move to class to `Node` within each
`Node`; the map from path list to value-list to `Leaf` in each `Node`; the map from path list to value-list to `Leaf` in each
`Continuation`; the map from path list to `Handler` in each `Leaf`; `Continuation`; the map from path list to `Handler` in each `Leaf`;
and the `Bag([V])` in every `Handler`. This reflects the fact that the and the `Bag([V])` in every `Handler`. This reflects the fact that the
index directly reflects the current state of the dataspace it is index directly reflects the current state of the dataspace it is
indexing. indexing.
#### From pattern shapes to tries of moves
**Definition.** A *visit* of a tree is a sequence of paths to nodes
within the tree. It may be described in two equivalent ways: as a
sequence of rooted (absolute) paths, `[H]`, or as a sequence of *moves*,
relative paths, `[Move]`.
w ∈ absolute visits [H]
w̅ ∈ relative visits [Move]
**Definition.** A *move* or *relative path* `h̅ ∈ Move` consists of zero
or more steps rootward from a position in a tree, followed by a path
from that position leafward in the tree. We define operators `⊕` and `⊖`
for applying a move to an existing path and computing a move from one
path to another, respectively:
⊕ :: H → Move → H
hₒ ⊕ (n, h) = dropRight n hₒ ++ h
⊖ :: H → H → Move
h ⊖ hₒ = (|hₒ| - |h'|, dropLeft |h'| h)
where
h' = longestCommonPrefix hₒ h
The first relative path in a relative visit is interpreted with respect
to the root of the tree. Relative and absolute visits are
interconvertible:
absToRel :: [H] → [Move]
absToRel hs = rel [] hs
where
rel hₒ [] = []
rel hₒ [h, h₁, ...] = [h ⊖ hₒ] ++ rel h [h₁, ...]
relToAbs :: [Move] → [H]
relToAbs hs = abs [] hs
where
abs hₒ [] = []
abs hₒ [h̅, h̅₁, ...] = [hₒ ⊕ h̅] ++ abs (hₒ ⊕ h̅) [h̅₁, ...]
**Definition.** The `shapeVisit` function converts a shape into a
sequence of `Move × L` pairs. The `Move`s in the sequence are a
visit of the nodes in the domain of the input shape.
shapeVisit :: S → [Move × L]
shapeVisit s = zip (absToRel (map fst s')) (map snd s')
where
s' = sort lexLt s
The utility `sort :: ∀A ∀B . (A → A → 2) → (A ⟼ B) → [(A, B)]`
produces a sorted sequence from a finite map and a "less-than"
predicate, which in this case is `lexLt`, the lexicographic ordering on
paths.
*Implementation note.* The type `S = (H ⟼ L)` is an (unordered) map, but
could equally well be a sequence of pairs `S = [H × L]` with the side
condition that the `H`s must be unique. With that representation,
`shape` can be adjusted to produce output in lexicographically-sorted
order, obviating the need for `sort` in `shapeVisit`.
*Implementation note.* In the special case of visiting a shape derived
from a pattern, a move `(n, h)` will always have either `|h| = 0` (if it
is the first move in the visit) or `|h| = 1` (if not). This allows
representation of moves in indexes as `𝐍 × (1 + 𝐍)` instead of the fully
general `𝐍 × H`.
**Lemma.** Every shape produced by `shape p` for a pattern `p` includes
a mapping for all and only the interior nodes of the tree embodied by
`p`. That is, every non-leaf node in `p` has a path in the domain of
`shape p`.
*Proof*. By induction on `p` and examination of `shape`. ∎
**Lemma.** Every relative path contained in a nonempty visit produced by
`shapeVisit (shape p)` has a leafward path of length one, except the
first such relative path, which always equals `(0, [])`.
*Proof*. By properties of the lexicographic ordering of paths and the
lemma above. The first path in `shapeVisit`'s result will always be the
relative path to the root node, `(0, [])`, since that is the smallest
possible path by the ordering. Subsequent paths will always be to an
*immediate* child of the current node or of one of its ancestors. If it
were not so, a contradiction would arise: since every interior node is
represented, every immediate child with children of its own must appear,
and lexicographic ordering requires that such nodes appear before their
own children, so "skipping" a generation is not possible. ∎
#### Adding and removing event handlers #### Adding and removing event handlers
Every event handler is a pair of a skeleton and a callback function. Every event handler is a pair of a skeleton and a callback function.
@ -239,64 +333,72 @@ itself to removal of handler functions, capture maps, and constant
maps. This assumption will have to be revisited in future broker-like maps. This assumption will have to be revisited in future broker-like
cases where handlers are dynamically installed. cases where handlers are dynamically installed.
**Definition.** The `project` function extracts the subvalue at a **Example.** Let our pattern be
given path `h` from an overall value `v`.
project :: V -> H -> V p = x(y(3, 4), $v, z(_, w(), _), _)
The skeleton of the pattern is then
k = (shape p, constantmap p, capturemap p)
shape p = ([] ⟼ x)
∪ ([0] ⟼ y)
∪ ([2] ⟼ z)
∪ ([2, 1] ⟼ w)
constantmap p = ([0, 0] ⟼ inl 3)
∪ ([0, 1] ⟼ inl 4)
∪ ([2, 0] ⟼ inr ())
∪ ([2, 2] ⟼ inr ())
∪ ([3] ⟼ inr ())
capturemap p = [[1]]
The shape-visit of `p` is thus
shapeVisit (shape p) = [((0, []), x),
((0, [0]), y),
((1, [2]), z),
((0, [1]), w)]
**Definition.** The partial `project` function extracts the subvalue at
a given path `h` from an overall value `v`.
project :: V → H ⇀ V
project v [] = v project v [] = v
project x(v_0, ..., v_i) (n:h) = project v_n h project x(v₀, ..., vᵢ) (n:h) = project vₙ h, if 0 ≤ n ≤ i
**Definition.** The `projectMany` function projects a sequence of **Definition.** The `projectMany` partial function projects a sequence
subvalues. of subvalues.
projectMany :: V -> [H] -> V projectMany :: V → [H] ⇀ [V]
projectMany v [h_0, ...] = [project v h_0, ...] projectMany v [h, ...] = [project v h, ...]
**Definition.** The `classof` function extracts the constructor label **Definition.** The `classof` partial function extracts the constructor
`x` from a value `v`, yielding `()` if `v` is not a record. label `x` from a record value. It is undefined for non-record values.
classof :: V -> 1 + Class classof :: V ⇀ L
classof a = () classof x(v₀, ..., vᵢ) = x
classof x(v_0, ..., v_i) = x
**Definition.** The `extend` procedure augments an index with shape **Definition.** The `extend` procedure augments an index with shape
information `s`, by imperatively updating the index structure. It information `s`, where `∃p . s = shape p`, by imperatively updating
returns the `Continuation` associated with the deepest `Node` the index structure. It returns the `Continuation` associated with the
visited in the path described by `s`. final `Node` visited in the path described by `s`.
extend :: Node -> S -> Continuation extend :: Index → S → Continuation
extend node s = extend (_, root) s = visit [] root (shapeVisit s)
let (_, (cont, _)) = walk-node [] node 0 0 s
cont
where where
visit :: H → Node → [Move × L] → Continuation
walk-edge :: H -> Node -> 𝐍 -> 𝐍 -> [S] -> (𝐍,Node) visit h (cont, moveTable) [] = cont
walk-edge h node n_pop n_index [] = visit h (cont, moveTable) ([(h̅, ℓ)] ++ moves) =
(n_pop + 1, node) if h̅ not in moveTable then
walk-edge h node n_pop n_index (s:shapes) = moveTable[h̅] := {}
let (n_pop', node') = walk-node h node n_pop n_index s let classTable = moveTable[h̅]
let n_index' = n_index + 1 if ℓ not in classTable then
let h' = (dropRight h 1) ++ [n_index'] let vs = { v | v ∈ fst cont,
walk-edge h' node' n_pop' n_index' shapes classof (project v (h ⊕ h̅)) = ℓ }
classTable[ℓ] := ((vs, {}), {})
walk-node :: H -> Node -> 𝐍 -> 𝐍 -> S -> (𝐍,Node) visit (h ⊕ h̅) classTable[ℓ] moves
walk-node h node n_pop n_index * =
(n_pop, node)
walk-node h node n_pop n_index x(s_0, ... s_i) =
let (cont, edges) = node
let selector = (n_pop,n_index)
let class = x
if selector not in edges then
edges[selector] := {}
let table = edges[selector]
if class not in table then
let (outercache, constmap) = cont
let innercache =
{ v | v ∈ outercache,
classof (project v h) = class }
table[class] := ((innercache, {}), {})
let node' = table[class]
walk-edge (h ++ [0]) node' 0 0 [s_0, ..., s_i]
**Definition.** The `addHandler` procedure installs into an index an **Definition.** The `addHandler` procedure installs into an index an
event handler callback `f` expecting values matching and captured by event handler callback `f` expecting values matching and captured by
@ -304,31 +406,35 @@ cases where handlers are dynamically installed.
sequence of captured values matching existing assertions in the sequence of captured values matching existing assertions in the
index.[^function-pointer-equality] index.[^function-pointer-equality]
addHandler :: Index -> (S × [H×V] × [H]) -> Callback -> 1 addHandler :: Index → K → Callback → 1
addHandler index (s, constantMap, captureMap) f = addHandler index (s, constantMap, captureMap) f =
let (_, root) = index let (cache, table) = extend index s
let (cache, table) = extend root s let (unsortedConstants, checks) = constantchecks constantMap
let constLocs = [h | (h,v) ∈ constantMap] let constants = sort lexLt unsortedConstants
if constLocs not in table then let constLocs = map fst constants
table[constLocs] := {} let constKey = (constLocs, checks)
if constKey not in table then
table[constKey] := {}
for v in cache for v in cache
let key = projectMany v constLocs if ∀h ∈ checks, project v h is defined and
if key not in table[constLocs] then ∃key . key = projectMany v constLocs then
table[constLocs][key] := ({}, {}) if key not in table[constKey] then
let (leafcache, _leaftable) = table[constLocs][key] table[constKey][key] := ({}, {})
leafcache += v let (leafcache, _leaftable) = table[constKey][key]
let constVals = [v | (h,v) ∈ constantMap] leafcache += v
if constVals not in table[constLocs] then let constVals = map snd constants
table[constLocs][constVals] := ({}, {}) if constVals not in table[constKey] then
let (leafcache, leaftable) = table[constLocs][constVals] table[constKey][constVals] := ({}, {})
let (leafcache, leaftable) = table[constKey][constVals]
if captureMap not in leaftable then if captureMap not in leaftable then
let bag = empty_bag let bag = empty_bag
for v in leafcache for v in leafcache
bag[projectMany v captureMap] += 1 if ∃seq . seq = projectMany v captureMap then
bag[seq] += 1
leaftable[captureMap] := (bag, {}) leaftable[captureMap] := (bag, {})
let (bag, f_table) = leaftable[captureMap] let (bag, f_table) = leaftable[captureMap]
f_table += f f_table += f
for seq in bag for (seq ⟼ _) in bag
f "+" seq f "+" seq
() ()
@ -340,17 +446,19 @@ cases where handlers are dynamically installed.
**Definition.** The `removeHandler` procedure removes an event handler **Definition.** The `removeHandler` procedure removes an event handler
from an index. from an index.
removeHandler :: Index -> (S × [H×V] × [H]) -> Callback -> 1 removeHandler :: Index → K → Callback → 1
removeHandler index (s, constantMap, captureMap) f = removeHandler index (s, constantMap, captureMap) f =
let (_, root) = index let (_, table) = extend index s
let (cache, table) = extend root s let (unsortedConstants, checks) = constantchecks constantMap
let constLocs = [h | (h,v) ∈ constantMap] let constants = sort lexLt unsortedConstants
if constLocs not in table then let constLocs = map fst constants
let constKey = (constLocs, checks)
if constKey not in table then
return return
let constVals = [v | (h,v) ∈ constantMap] let constVals = map snd constants
if constVals not in table[constLocs] then if constVals not in table[constKey] then
return return
let (leafcache, leaftable) = table[constLocs][constVals] let (leafcache, leaftable) = table[constKey][constVals]
if captureMap not in leaftable then if captureMap not in leaftable then
return return
let (bag, f_table) = leaftable[captureMap] let (bag, f_table) = leaftable[captureMap]
@ -360,9 +468,9 @@ cases where handlers are dynamically installed.
if f_table = {} then if f_table = {} then
delete leaftable[captureMap] delete leaftable[captureMap]
if leafcache = {} and leaftable = {} then if leafcache = {} and leaftable = {} then
delete table[constLocs][constVals] delete table[constKey][constVals]
if table[constLocs] = {} then if table[constKey] = {} then
delete table[constLocs] delete table[constKey]
#### Adding assertions, removing assertions and sending messages #### Adding assertions, removing assertions and sending messages
@ -377,70 +485,59 @@ parameterized with different update procedures.
Operation = { AddAssertion, RemoveAssertion, SendMessage } Operation = { AddAssertion, RemoveAssertion, SendMessage }
modify :: Node -> modify :: Index →
Operation -> Operation →
V -> V →
(Continuation -> V -> 1) -> (Continuation → V → 1) →
(Leaf -> V -> 1) -> (Leaf → V → 1) →
(Handler -> [V] -> 1) -> (Handler → [V] → 1) →
1 1
modify node operation v m_cont m_leaf m_handler = modify (_, root) operation v m_cont m_leaf m_handler =
walk-node node [outermost(v)] visit root [v]
where where
walk-node :: Node -> [V] -> 1 visit :: Node → [V] → 1
walk-node (cont, edges) vs = visit (cont, moveTable) vs =
walk-cont cont visit-cont cont
for sel@(n_pop, n_index) in edges for ((n, h) ⟼ classTable) in moveTable
let vs' = dropLeft vs n_pop let (v' : vs') = dropLeft vs n in
let (x(v_0, ...) : _) = vs' if ∃v . v = project v' h and
let v' = v_{n_index} ∃ℓ . ℓ = classof v and
if classof v' in edges[sel] then ∃next . (ℓ ⟼ next) ∈ classTable then
walk-node edges[sel][classof v'] (v':vs') visit next (v : v' : vs')
walk-cont :: Continuation -> 1 visit-cont :: Continuation → 1
walk-cont cont@(cache, table) = visit-cont cont@(_, table) =
m_cont cont v m_cont cont v
for constLocs in table for ((constLocs, checks) ⟼ constVals) in table
let consts = projectMany v constLocs if ∀h ∈ checks, project v h is defined and
if operation = AddAssertion and consts not in table[constLocs] then ∃consts . consts = projectMany v constLocs then
table[constLocs][consts] := ({}, {}) if operation = AddAssertion and consts not in constVals then
if consts in table[constLocs] then constVals[consts] := ({}, {})
let leaf@(leafcache, leaftable) = if consts in constVals then
table[constLocs][consts] let leaf@(leafcache, leaftable) = constVals[consts]
m_leaf leaf v m_leaf leaf v
for captureMap in leaftable for (captureMap ⟼ handler) in leaftable
let handler = leaftable[captureMap] if ∃vs . vs = projectMany v captureMap then
let vs = projectMany v captureMap m_handler handler vs
m_handler handler vs if operation = RemoveAssertion and leafcache = {} and leaftable = {} then
if operation = RemoveAssertion and leafcache = {} and leaftable = {} then delete constVals[consts]
delete table[constLocs][consts] if constVals = {} then
if table[constLocs] = {} then delete table[(constLocs, checks)]
delete table[constLocs]
The `outermost` constructor applied to `v` at the top of `modify` is
necessary because every path in the trie structure embodied in each
`node` is a sequence of zero or more (move, check) pairs. Each "move"
pops zero or more items from the stack and then pushes a sub-structure
of the topmost stack element onto the stack; the "check" then examines
the class of the new top element, abandoning the search if it does not
match. Without some outermost constructor, there would be no possible
"move", and the trie would have to be expressed as a single optional
check followed by zero or more (move, check) pairs.
**Definition.** The procedure `adjustAssertion` updates the copy-count **Definition.** The procedure `adjustAssertion` updates the copy-count
associated with `v` in the given index, invoking callbacks as a associated with `v` in the given index, invoking callbacks as a
side-effect if this changes the observable contents of the side-effect if this changes the observable contents of the
dataspace. dataspace.
adjustAssertion :: Index -> V -> 𝐍 -> 1 adjustAssertion :: Index → V → 𝐍 → 1
adjustAssertion (cache, root) v delta = adjustAssertion index@(cache, root) v delta =
let was_present = v in cache let was_present = v in cache
cache[v] += delta cache[v] += delta
let is_present = v in cache let is_present = v in cache
if not was_present and is_present then if not was_present and is_present then
modify root AddAssertion v add_cont add_leaf add_handler modify index AddAssertion v add_cont add_leaf add_handler
if was_present and not is_present then if was_present and not is_present then
modify root RemoveAssertion v del_cont del_leaf del_handler modify index RemoveAssertion v del_cont del_leaf del_handler
where where
add_cont (cache, _) v = cache += v add_cont (cache, _) v = cache += v
add_leaf (leafcache, _) v = leafcache += v add_leaf (leafcache, _) v = leafcache += v
@ -463,10 +560,10 @@ check followed by zero or more (move, check) pairs.
install and remove an assertion `v` into the given index, install and remove an assertion `v` into the given index,
respectively. respectively.
addAssertion :: Index -> V -> 1 addAssertion :: Index → V → 1
addAssertion index v = adjustAssertion index v 1 addAssertion index v = adjustAssertion index v 1
removeAssertion :: Index -> V -> 1 removeAssertion :: Index → V → 1
removeAssertion index v = adjustAssertion index v -1 removeAssertion index v = adjustAssertion index v -1
Care must be taken when applying entire *patches* to ensure that added Care must be taken when applying entire *patches* to ensure that added
@ -481,7 +578,7 @@ processed first, no glitch will be detected.
**Definition.** The procedure `sendMessage` delivers a message `v` to **Definition.** The procedure `sendMessage` delivers a message `v` to
event handlers in the given index. event handlers in the given index.
sendMessage :: Index -> V -> 1 sendMessage :: Index → V → 1
sendMessage (_, root) v = sendMessage (_, root) v =
modify root SendMessage v send_cont send_leaf send_handler modify root SendMessage v send_cont send_leaf send_handler
where where
@ -491,8 +588,32 @@ processed first, no glitch will be detected.
for f in f_table for f in f_table
f "!" vs f "!" vs
## Variations
### Exact arity matching
The initial version of this design had
k ∈ skeletons K = S × (H ⟼ V) × [H]
ℓ ∈ classes L = X × 𝐍 -- label and arity
which provided for exact arity matching instead of extensible "at-least"
arity matching. Constant maps contained `V` rather than `V+1` because
the arity check as part of the class obviated the need to check a
position for mere existence.
### Matching atom classes
Skeleton constant map predicates `V+1` can be changed to include any
other kind of predicate besides equal-to-expected-value `V` and simple
existence `1`, such as `string?`/`int?`/etc.
## Potential future optimizations ## Potential future optimizations
### JIT compilation of shapes, constant checks, captures
TODO
### Static analysis of messages and assertions ### Static analysis of messages and assertions
Static analysis of expressions under `(send! ...)` and `(assert ...)` Static analysis of expressions under `(send! ...)` and `(assert ...)`

2
syndicate/drivers/racket-event.rkt
View File

@ -14,7 +14,7 @@
(provide-service [ds] (provide-service [ds]
(at ds (at ds
(during/spawn (Observe (:pattern (RacketEvent ,(DLit $embedded-event) ,_)) _) (during/spawn (Observe (:pattern (RacketEvent ,(Pattern-lit $embedded-event) ,_)) _)
#:name (embedded-value embedded-event) #:name (embedded-value embedded-event)
(define event (embedded-value embedded-event)) (define event (embedded-value embedded-event))
(linked-thread (linked-thread

2
syndicate/drivers/tcp.rkt
View File

@ -23,7 +23,7 @@
(with-services [syndicate/drivers/stream] (with-services [syndicate/drivers/stream]
(at ds (at ds
(during/spawn (during/spawn
(Observe (:pattern (StreamConnection ,_ ,_ (TcpLocal ,(DLit $host) ,(DLit $port)))) _) (Observe (:pattern (StreamConnection ,_ ,_ (TcpLocal ,(Pattern-lit $host) ,(Pattern-lit $port)))) _)
#:name (TcpLocal host port) #:name (TcpLocal host port)
(run-listener ds host port)) (run-listener ds host port))

2
syndicate/drivers/timer.rkt
View File

@ -88,7 +88,7 @@
(log-syndicate/drivers/timer-debug "received instruction ~a" instruction) (log-syndicate/drivers/timer-debug "received instruction ~a" instruction)
(channel-put control-ch instruction)) (channel-put control-ch instruction))
(during (Observe (:pattern (LaterThan ,(DLit $seconds))) _) (during (Observe (:pattern (LaterThan ,(Pattern-lit $seconds))) _)
(log-syndicate/drivers/timer-debug "observing (later-than ~a) at ~a" (log-syndicate/drivers/timer-debug "observing (later-than ~a) at ~a"
seconds seconds
(/ (current-inexact-milliseconds) 1000.0)) (/ (current-inexact-milliseconds) 1000.0))

45
syndicate/pattern.rkt
View File

@ -13,8 +13,10 @@
:pattern :pattern
:parse :parse
pattern->shape
pattern->constant-values pattern->constant-values
pattern->constant-paths pattern->constant-paths
pattern->check-paths
pattern->capture-paths pattern->capture-paths
!dump-registered-preserves-patterns! !dump-registered-preserves-patterns!
@ -180,14 +182,14 @@
[id [id
(dollar-id? #'id) (dollar-id? #'id)
(transform-binding (undollar #'id) #`(Pattern-DBind (DBind (Pattern-DDiscard (DDiscard)))))] (transform-binding (undollar #'id) #`(Pattern-bind (Pattern-discard)))]
[($ id p) [($ id p)
(transform-binding #'id #`(Pattern-DBind (DBind #,(walk #'p))))] (transform-binding #'id #`(Pattern-bind #,(walk #'p)))]
[id [id
(discard-id? #'id) (discard-id? #'id)
#`(Pattern-DDiscard (DDiscard))] #`(Pattern-discard)]
[(c l (list-stx piece ...)) [(c l (list-stx piece ...))
(and (id=? #'rec #'c) (and (id=? #'rec #'c)
@ -379,36 +381,55 @@
;;--------------------------------------------------------------------------- ;;---------------------------------------------------------------------------
(define (select-pattern-leaves desc capture-fn lit-fn) (define (pattern->shape desc)
(let walk-node ((key-rev '()) (desc desc)) (let walk-node ((key-rev '()) (desc desc))
(match desc (match desc
[(Pattern-DCompound (or (DCompound-rec _ fields) [(Pattern-group type entries)
(DCompound-arr fields))) (append* (list (cons (reverse key-rev) type))
(append* (for/list [(key (in-naturals)) (subdesc (in-list fields))] (for/list [((key subdesc) (in-hash entries))]
(walk-node (cons key key-rev) subdesc)))] (walk-node (cons key key-rev) subdesc)))]
[(Pattern-DCompound (DCompound-dict entries)) [(Pattern-bind subdesc)
(walk-node key-rev subdesc)]
[(Pattern-discard)
'()]
[(Pattern-lit value)
'()])))
(define (select-pattern-leaves desc capture-fn discard-fn lit-fn)
(let walk-node ((key-rev '()) (desc desc))
(match desc
[(Pattern-group _type entries)
(append* (for/list [((key subdesc) (in-hash entries))] (append* (for/list [((key subdesc) (in-hash entries))]
(walk-node (cons key key-rev) subdesc)))] (walk-node (cons key key-rev) subdesc)))]
[(Pattern-DBind (DBind subdesc)) [(Pattern-bind subdesc)
(append (capture-fn key-rev) (walk-node key-rev subdesc))] (append (capture-fn key-rev) (walk-node key-rev subdesc))]
[(Pattern-DDiscard (DDiscard)) [(Pattern-discard)
'()] (discard-fn key-rev)]
[(Pattern-DLit (DLit value)) [(Pattern-lit value)
(lit-fn key-rev (->preserve value))]))) (lit-fn key-rev (->preserve value))])))
(define (pattern->constant-values desc) (define (pattern->constant-values desc)
(select-pattern-leaves desc (select-pattern-leaves desc
(lambda (key-rev) (list))
(lambda (key-rev) (list)) (lambda (key-rev) (list))
(lambda (key-rev value) (list value)))) (lambda (key-rev value) (list value))))
(define (pattern->constant-paths desc) (define (pattern->constant-paths desc)
(select-pattern-leaves desc (select-pattern-leaves desc
(lambda (key-rev) (list))
(lambda (key-rev) (list)) (lambda (key-rev) (list))
(lambda (key-rev value) (list (reverse key-rev))))) (lambda (key-rev value) (list (reverse key-rev)))))
(define (pattern->check-paths desc)
(select-pattern-leaves desc
(lambda (key-rev) (list))
(lambda (key-rev) (list (reverse key-rev)))
(lambda (key-rev value) (list))))
(define (pattern->capture-paths desc) (define (pattern->capture-paths desc)
(select-pattern-leaves desc (select-pattern-leaves desc
(lambda (key-rev) (list (reverse key-rev))) (lambda (key-rev) (list (reverse key-rev)))
(lambda (key-rev) (list))
(lambda (key-rev value) (list)))) (lambda (key-rev value) (list))))
(define-syntax (!dump-registered-preserves-patterns! stx) (define-syntax (!dump-registered-preserves-patterns! stx)

6
syndicate/schema-compiler.rkt
View File

@ -62,7 +62,7 @@
[(SimplePattern-Ref (Ref (ModulePath module-path) name)) `values])) [(SimplePattern-Ref (Ref (ModulePath module-path) name)) `values]))
(define (def-pattern name def) (define (def-pattern name def)
(define discard `(,(N 'Pattern-DDiscard) (,(N 'DDiscard)))) (define discard `(,(N 'Pattern-discard)))
(define (pat-pattern p) (define (pat-pattern p)
(match (unwrap p) (match (unwrap p)
@ -73,8 +73,8 @@
[(SimplePattern-embedded _interface) discard] [(SimplePattern-embedded _interface) discard]
[(SimplePattern-lit value) [(SimplePattern-lit value)
(if (eq? value '...) (if (eq? value '...)
`(,(N 'Pattern-DLit) (,(N 'DLit) (quote (... ...)))) `(,(N 'Pattern-lit) (quote (... ...)))
`(,(N 'Pattern-DLit) (,(N 'DLit) ',value)))] `(,(N 'Pattern-lit) ',value))]
[(SimplePattern-seqof pat) discard] [(SimplePattern-seqof pat) discard]
[(SimplePattern-setof pat) discard] [(SimplePattern-setof pat) discard]
[(SimplePattern-dictof key-pat value-pat) discard] [(SimplePattern-dictof key-pat value-pat) discard]

176
syndicate/skeleton.rkt
View File

@ -31,16 +31,16 @@
;; specification of (the outline of) its shape; its silhouette. ;; specification of (the outline of) its shape; its silhouette.
;; Following a skeleton's structure leads to zero or more `SkCont`s. ;; Following a skeleton's structure leads to zero or more `SkCont`s.
;; ;;
;; Skeleton = (skeleton-node SkCont (AListof SkSelector (MutableHash ConstructorSpec Skeleton))) ;; Skeleton = (skeleton-node SkCont (AListof SkMove (MutableHash ConstructorSpec Skeleton)))
;; SkSelector = (skeleton-selector Nat Any) ;; SkMove = (skeleton-move Nat (Listof Any))
;; ;;
;; A `ConstructorSpec` specifies a record label with arity, or a list ;; A `ConstructorSpec` specifies a record and its label, or a sequence,
;; arity, or a dictionary. ;; or a dictionary.
;; ;;
;; ConstructorSpec = (U (cons any nat) nat 'dict) ;; ConstructorSpec = (U (GroupType-rec any) (GroupType-arr) (GroupType-dict))
;; ;;
(struct skeleton-node (continuation [edges #:mutable]) #:transparent) (struct skeleton-node (continuation [edges #:mutable]) #:transparent)
(struct skeleton-selector (pop-count key) #:transparent) (struct skeleton-move (pop-count path) #:transparent)
;; ;;
;; A `Pattern` is a pattern over assertions, following the schema of ;; A `Pattern` is a pattern over assertions, following the schema of
;; the same name in schemas/dataspacePatterns.prs. Instances of ;; the same name in schemas/dataspacePatterns.prs. Instances of
@ -57,7 +57,8 @@
;; ;;
;; SkCont = (skeleton-continuation ;; SkCont = (skeleton-continuation
;; (MutableHash Assertion #t) ;; (MutableHash Assertion #t)
;; (MutableHash SkProj (MutableHash SkKey SkConst))) ;; (MutableHash (constant-positions SkProj SkProj)
;; (MutableHash SkKey SkConst)))
;; SkConst = (skeleton-matched-constant ;; SkConst = (skeleton-matched-constant
;; (MutableHash Assertion #t) ;; (MutableHash Assertion #t)
;; (MutableHash SkProj SkAcc)) ;; (MutableHash SkProj SkAcc))
@ -66,6 +67,7 @@
;; (MutableHasheq EntityRef (MutableHash SkKey Handle))) ;; (MutableHasheq EntityRef (MutableHash SkKey Handle)))
;; ;;
(struct skeleton-continuation (cache table) #:transparent) (struct skeleton-continuation (cache table) #:transparent)
(struct constant-positions (with-values required-to-exist) #:transparent)
(struct skeleton-matched-constant (cache table) #:transparent) (struct skeleton-matched-constant (cache table) #:transparent)
(struct skeleton-accumulator (cache peers) #:transparent) (struct skeleton-accumulator (cache peers) #:transparent)
;; ;;
@ -106,15 +108,19 @@
(define (skcont-add! turn c pat ref) (define (skcont-add! turn c pat ref)
(define cs (pattern->constant-paths pat)) (define cs (pattern->constant-paths pat))
(define ce (pattern->check-paths pat))
(define (classify-assertions) (define (classify-assertions)
(define cvt (make-hash)) (define cvt (make-hash))
(hash-for-each (skeleton-continuation-cache c) (hash-for-each (skeleton-continuation-cache c)
(lambda (a _) (lambda (a _)
(define avs (apply-projection a cs)) (unless (void? (apply-projection a ce))
(define sc (hash-ref! cvt avs make-empty-matched-constant)) (define avs (apply-projection a cs))
(hash-set! (skeleton-matched-constant-cache sc) a #t))) (unless (void? avs)
(define sc (hash-ref! cvt avs make-empty-matched-constant))
(hash-set! (skeleton-matched-constant-cache sc) a #t)))))
cvt) cvt)
(define cvt (hash-ref! (skeleton-continuation-table c) cs classify-assertions)) (define cvt
(hash-ref! (skeleton-continuation-table c) (constant-positions cs ce) classify-assertions))
(define sc (hash-ref! cvt (pattern->constant-values pat) make-empty-matched-constant)) (define sc (hash-ref! cvt (pattern->constant-values pat) make-empty-matched-constant))
(define vs (pattern->capture-paths pat)) (define vs (pattern->capture-paths pat))
(define (make-accumulator) (define (make-accumulator)
@ -133,8 +139,9 @@
(and (hash-empty? cache) (hash-empty? table))) (and (hash-empty? cache) (hash-empty? table)))
(define (skcont-remove! turn c pat ref) (define (skcont-remove! turn c pat ref)
(define cs (pattern->constant-paths pat)) (define ck (constant-positions (pattern->constant-paths pat)
(define cvt (hash-ref (skeleton-continuation-table c) cs #f)) (pattern->check-paths pat)))
(define cvt (hash-ref (skeleton-continuation-table c) ck #f))
(when cvt (when cvt
(define cv (pattern->constant-values pat)) (define cv (pattern->constant-values pat))
(define sc (hash-ref cvt cv #f)) (define sc (hash-ref cvt cv #f))
@ -150,65 +157,60 @@
(when (skeleton-matched-constant-empty? sc) (when (skeleton-matched-constant-empty? sc)
(hash-remove! cvt cv))) (hash-remove! cvt cv)))
(when (hash-empty? cvt) (when (hash-empty? cvt)
(hash-remove! (skeleton-continuation-table c) cs)))) (hash-remove! (skeleton-continuation-table c) ck))))
(define (⊖ h1 h0)
(define-values (h1tail h0tail) (drop-common-prefix h1 h0))
(skeleton-move (length h0tail) h1tail))
(define (⊕ h0 move)
(match-define (skeleton-move n h) move)
(append (drop-right h0 n) h))
(define (shape->visit s)
(let walk ((path '()) (s s))
(match s
['() '()]
[(cons (cons h ctor-spec) more)
(cons (cons (⊖ h path) ctor-spec) (walk h more))])))
(define (term-matches-ctor-spec? term ctor-spec) (define (term-matches-ctor-spec? term ctor-spec)
(match ctor-spec (match ctor-spec
[(cons 'rec label) [(GroupType-rec label)
(and (non-object-struct? term) (and (non-object-struct? term)
(equal? (struct-type-name (struct->struct-type term)) label))] (equal? (struct-type-name (struct->struct-type term)) label))]
['arr [(GroupType-arr)
(list? term)] (list? term)]
['dict [(GroupType-dict)
(hash? term)])) (hash? term)]))
(define (subterm-matches-ctor-spec? term path ctor-spec) (define (subterm-matches-ctor-spec? term path ctor-spec)
(term-matches-ctor-spec? (apply-projection-path term path) ctor-spec)) (term-matches-ctor-spec? (apply-projection-path term path) ctor-spec))
(define (skeleton-node-edge-table! sk move)
(match (assoc move (skeleton-node-edges sk))
[#f (let ((table (make-hash)))
(set-skeleton-node-edges! sk (cons (cons move table) (skeleton-node-edges sk)))
table)]
[(cons _move table) table]))
(define (extend-skeleton! sk pat) (define (extend-skeleton! sk pat)
(define (walk-node! rev-path sk pop-count key pat) (let visit ((h '()) (sk sk) (moves (shape->visit (pattern->shape pat))))
(match pat (match moves
[(Pattern-DCompound compound-pat) ['() sk]
(define selector (skeleton-selector pop-count key)) [(cons (cons move ctor-spec) moves)
(define table (define table (skeleton-node-edge-table! sk move))
(match (assoc selector (skeleton-node-edges sk)) (define path (⊕ h move))
[#f (let ((table (make-hash)))
(set-skeleton-node-edges! sk (cons (cons selector table) (skeleton-node-edges sk)))
table)]
[(cons _selector table) table]))
(define ctor-spec
(match compound-pat
[(DCompound-rec label field-pats) (cons 'rec label)]
[(DCompound-arr item-pats) 'arr]
[(DCompound-dict _entries) 'dict]))
(define (make-skeleton-node-with-cache) (define (make-skeleton-node-with-cache)
(define unfiltered (skeleton-continuation-cache (skeleton-node-continuation sk))) (define unfiltered (skeleton-continuation-cache (skeleton-node-continuation sk)))
(define filtered (make-hash)) (define filtered (make-hash))
(define path (reverse rev-path))
(hash-for-each unfiltered (hash-for-each unfiltered
(lambda (a _) (lambda (a _)
(when (subterm-matches-ctor-spec? a path ctor-spec) (when (subterm-matches-ctor-spec? a path ctor-spec)
(hash-set! filtered a #t)))) (hash-set! filtered a #t))))
(make-empty-skeleton/cache filtered)) (make-empty-skeleton/cache filtered))
(define next (hash-ref! table ctor-spec make-skeleton-node-with-cache)) (define next (hash-ref! table ctor-spec make-skeleton-node-with-cache))
(let-values (((pop-count sk) (visit path next moves)])))
(match compound-pat
[(or (DCompound-rec _ pats)
(DCompound-arr pats))
(for/fold [(pop-count 0) (sk next)]
[(key (in-naturals)) (subpat (in-list pats))]
(walk-node! (cons key rev-path) sk pop-count key subpat))]
[(DCompound-dict members)
(for/fold [(pop-count 0) (sk next)]
[((key subpat) (in-hash members))]
(walk-node! (cons key rev-path) sk pop-count key subpat))])))
(values (+ pop-count 1) sk))]
[(Pattern-DBind (DBind pat))
(walk-node! rev-path sk pop-count key pat)]
[_
(values pop-count sk)]))
(let-values (((_pop-count sk) (walk-node! '() sk 0 0 pat)))
sk))
(define (add-interest! turn sk pat ref) (define (add-interest! turn sk pat ref)
(skcont-add! turn (skeleton-node-continuation (extend-skeleton! sk pat)) pat ref)) (skcont-add! turn (skeleton-node-continuation (extend-skeleton! sk pat)) pat ref))
@ -217,45 +219,45 @@
(skcont-remove! turn (skeleton-node-continuation (extend-skeleton! sk pat)) pat ref)) (skcont-remove! turn (skeleton-node-continuation (extend-skeleton! sk pat)) pat ref))
(define (skeleton-modify! turn sk term0 modify-skcont! on-missing-skconst modify-skconst! modify-skacc!) (define (skeleton-modify! turn sk term0 modify-skcont! on-missing-skconst modify-skconst! modify-skacc!)
(let walk-node! ((sk sk) (term-stack (list (list term0)))) (let walk-node! ((sk sk) (term-stack (list term0)))
(match-define (skeleton-node continuation edges) sk) (match-define (skeleton-node continuation edges) sk)
(modify-skcont! continuation term0) (modify-skcont! continuation term0)
(let ((sct (skeleton-continuation-table continuation)) (let ((sct (skeleton-continuation-table continuation))
(constant-projections-to-remove '())) (constant-keys-to-remove '()))
(hash-for-each sct (for [((constant-key key-proj-handler) (in-hash sct))]
(lambda (constant-proj key-proj-handler) (unless (void? (apply-projection term0 (constant-positions-required-to-exist constant-key)))
(define constants (apply-projection term0 constant-proj)) (define constants (apply-projection term0 (constant-positions-with-values constant-key)))
(define proj-handler (unless (void? constants)
(hash-ref key-proj-handler (define proj-handler
constants (hash-ref key-proj-handler
(lambda () (on-missing-skconst key-proj-handler constants)))) constants
(when proj-handler (lambda () (on-missing-skconst key-proj-handler constants))))
(when (eq? (modify-skconst! proj-handler term0) 'remove-check) (when proj-handler
(when (skeleton-matched-constant-empty? proj-handler) (when (eq? (modify-skconst! proj-handler term0) 'remove-check)
(hash-remove! key-proj-handler constants) (when (skeleton-matched-constant-empty? proj-handler)
(when (hash-empty? key-proj-handler) (hash-remove! key-proj-handler constants)
(set! constant-projections-to-remove (when (hash-empty? key-proj-handler)
(cons constant-proj constant-projections-to-remove))))) (set! constant-keys-to-remove (cons constant-key constant-keys-to-remove)))))
(hash-for-each (skeleton-matched-constant-table proj-handler) (hash-for-each (skeleton-matched-constant-table proj-handler)
(lambda (variable-proj acc) (lambda (variable-proj acc)
(define vars (apply-projection term0 variable-proj)) (define vars (apply-projection term0 variable-proj))
(modify-skacc! turn acc vars term0)))))) (modify-skacc! turn acc vars term0)))))))
(for-each (lambda (constant-proj) (hash-remove! sct constant-proj)) (for [(constant-key (in-list constant-keys-to-remove))]
constant-projections-to-remove)) (hash-remove! sct constant-key)))
(for [(edge (in-list edges))] (for [(edge (in-list edges))]
(match-define (cons (skeleton-selector pop-count key) table) edge) (match-define (cons (skeleton-move pop-count path) table) edge)
(define popped-stack (drop term-stack pop-count)) (define popped-stack (drop term-stack pop-count))
(define old-top (car popped-stack)) (define old-top (car popped-stack))
(define new-top (step-term old-top key)) (define new-top (apply-projection-path old-top path))
(define entry (define ctor-spec (cond [(non-object-struct? new-top)
(hash-ref table (GroupType-rec (struct-type-name
(cond [(non-object-struct? new-top) (cons 'rec (struct-type-name (struct->struct-type new-top)))]
(struct->struct-type new-top)))] [(list? new-top) (GroupType-arr)]
[(list? new-top) 'arr] [(hash? new-top) (GroupType-dict)]
[(hash? new-top) 'dict] [else #f]))
[else #f]) (define entry (hash-ref table ctor-spec #f))
#f))
(when entry (walk-node! entry (cons new-top popped-stack)))))) (when entry (walk-node! entry (cons new-top popped-stack))))))
(define (add-term-to-skcont! skcont term) (define (add-term-to-skcont! skcont term)
@ -331,8 +333,12 @@
;; TODO: avoid repeated descent into `term` by factoring out prefixes of paths in `proj` ;; TODO: avoid repeated descent into `term` by factoring out prefixes of paths in `proj`
(define (apply-projection term proj) (define (apply-projection term proj)
(for/list [(path (in-list proj))] (let/ec return
(apply-projection-path term path))) (for/list [(path (in-list proj))]
(define v (apply-projection-path term path))
(if (void? v)
(return (void))
v))))
(define (apply-projection-path term path) (define (apply-projection-path term path)
(for/fold [(term term)] (for/fold [(term term)]

44
syndicate/smart-pattern.rkt
View File

@ -23,13 +23,28 @@
(require syndicate/schemas/dataspacePatterns) (require syndicate/schemas/dataspacePatterns)
(define (rec label pats) (Pattern-DCompound (DCompound-rec label pats))) (define (items->entries pats)
(define (arr pats) (Pattern-DCompound (DCompound-arr pats))) (define-values (entries max-i)
(define (dict pats) (Pattern-DCompound (DCompound-dict pats))) (for/fold [(entries (hash)) (max-i #f)]
[(i (in-naturals)) (p (in-list pats))]
(values (if (Pattern-discard? p) entries (hash-set entries i p))
i)))
(if (and max-i (not (hash-has-key? entries max-i)))
(hash-set entries max-i (Pattern-discard))
entries))
(define (rec* label pats) (rec 'rec (list (lit label) (arr pats)))) (define (entries->items entries on-missing)
(define (arr* pats) (rec 'arr (list (arr pats)))) (define max-key (apply max -1 (hash-keys entries)))
(define (dict* pats) (rec 'dict (list (dict pats)))) (for/list [(i (in-range 0 (+ max-key 1)))]
(hash-ref entries i on-missing)))
(define (rec label pats) (Pattern-group (GroupType-rec label) (items->entries pats)))
(define (arr pats) (Pattern-group (GroupType-arr) (items->entries pats)))
(define (dict pats) (Pattern-group (GroupType-dict) pats))
(define (rec* label pats) (rec 'group (list (rec 'rec (list (lit label))) (dict (items->entries pats)))))
(define (arr* pats) (rec 'group (list (rec 'arr (list)) (dict (items->entries pats)))))
(define (dict* pats) (rec 'group (list (rec 'dict (list)) (dict pats))))
(define (literal->literal-pattern v) (define (literal->literal-pattern v)
(let walk ((v (->preserve v))) (let walk ((v (->preserve v)))
@ -37,18 +52,19 @@
[(record label fs) (rec label (map walk fs))] [(record label fs) (rec label (map walk fs))]
[(? list? vs) (arr (map walk vs))] [(? list? vs) (arr (map walk vs))]
[(? dict? d) (dict (for/hash [((k v) (in-hash d))] (values k (walk v))))] [(? dict? d) (dict (for/hash [((k v) (in-hash d))] (values k (walk v))))]
[other (Pattern-DLit (DLit (parse-AnyAtom! other)))]))) [other (Pattern-lit (parse-AnyAtom! other))])))
(define lit literal->literal-pattern) (define lit literal->literal-pattern)
(define (literal-pattern->literal p) (define (literal-pattern->literal p)
(let/ec return (let/ec return
(define (e->i e) (entries->items e (lambda () (return (void)))))
(let walk ((p p)) (let walk ((p p))
(match p (match p
[(Pattern-DDiscard (DDiscard)) (return (void))] [(Pattern-discard) (return (void))]
[(Pattern-DBind (DBind pp)) (walk pp)] [(Pattern-bind pp) (walk pp)]
[(Pattern-DLit (DLit a)) (->preserve a)] [(Pattern-lit a) (->preserve a)]
[(Pattern-DCompound (DCompound-rec label ps)) (record label (map walk ps))] [(Pattern-group (GroupType-rec label) ps) (record label (map walk (e->i ps)))]
[(Pattern-DCompound (DCompound-arr ps)) (map walk ps)] [(Pattern-group (GroupType-arr) ps) (map walk (e->i ps))]
[(Pattern-DCompound (DCompound-dict d)) (for/hash [((k pp) (in-hash d))] [(Pattern-group (GroupType-dict) d) (for/hash [((k pp) (in-hash d))]
(values k (walk pp)))])))) (values k (walk pp)))]))))