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
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
model of Conversational Concurrency [is great], but implementing it
@ -29,7 +29,7 @@ language.
x ∈ identifiers X
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:
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
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
directly. Binding subpatterns `$x` are translated into `capture()`,
@ -113,10 +113,9 @@ event handlers added later.
### Skeletons
A skeleton is comprised of three pieces: a *shape*, describing the
positions and arities of statically-known constructors in matching
assertions; a *constant map*, which places restrictions on fields
within constructors; and a *capture map*, which specifies locations of
captured positions.
positions of statically-known constructors in matching assertions; a
*constant map*, which places restrictions on fields within constructors;
and a *capture map*, which specifies locations of captured positions.
Each time an assertion is added or removed, it is conceptually 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
argument vector, and the event handler's callback is invoked.
k ∈ skeletons K = S × [H×E] × [H]
s ∈ shapes S ::= * | x(s, ...)
h ∈ paths H = [𝐍]
k ∈ skeletons K = S × (H ⟼ V+1) × [H]
s ∈ shapes S = (H ⟼ L)
ℓ ∈ classes L = X -- label
h ∈ paths H = [𝐍]
Shapes retain only statically-known constructors and arities in a
pattern:
Shapes retain only statically-known constructors in a pattern:
shape :: P -> S
shape e = *
shape x(p, ...) = x(shape p, ...)
shape $x = *
shape _ = *
shape :: P → S
shape p = shape' [] p
where
shape' :: H → P → S
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
pattern. The expressions in the map are evaluated at the time the
corresponding event handler is installed; that is, at facet creation
time. They are not subsequently reevaluated; if any expression depends
on a dataflow variable, and that variable changes, the entire handler
is removed, reevaluated, and reinstalled.
A constant map filters potential matches by placing constraints on
contained fields. The paths `H` in the map denote positions to be
checked; the predicates `V+1` denote either a particular value that must
exist at that position, or a simple check that the term in question
merely *has* a value in that position.
constantmap :: P -> [(H, E)]
constantmap :: P → (H ⟼ V+1)
constantmap p = cmap [] p
where
cmap :: H -> P -> [(H, E)]
cmap h e = [(h, e)]
cmap h x(p_0, ..., p_i) = (cmap (h++[0]) p_0) ++
... ++
(cmap (h++[i]) p_i)
cmap h $x = []
cmap h _ = []
cmap :: H → P → (H ⟼ V+1)
cmap h v = (h ⟼ inl v)
cmap h x(p₀, ..., pᵢ) = (cmap (h++[0]) p₀) ∪ ...
∪ (cmap (h++[i]) pᵢ)
cmap h $x = ∅
cmap h _ = (h ⟼ inr ())
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
where
vmap :: H -> P -> [H]
vmap h e = []
vmap h x(p_0, ..., p_i) = (vmap (h++[0]) p_0) ++
... +
(vmap (h++[i]) p_i)
vmap h $x = [h]
vmap h _ = []
vmap :: H → P → [H]
vmap h v = []
vmap h x(p₀, ..., pᵢ) = (vmap (h++[0]) p₀) ++ ...
++ (vmap (h++[i]) pᵢ)
vmap h $x = [h]
vmap h _ = []
### The index
@ -175,8 +182,8 @@ assertion in the dataspace.
#### Overview and structures
An index is a pair of a bag of all currently-asserted
assertion-values, plus the root node of a trie-like structure.
An index contains a bag of all currently-asserted
assertion-values, as well as the root of a trie-like structure.
Information from each indexed event handler's skeleton's shape is laid
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.
Index = Bag(V) × Node
Node = Continuation × (Selector ⟼ Class ⟼ Node)
Selector = 𝐍 × 𝐍 -- pop-count and index
Class = X -- label
Node = Continuation × (Move ⟼ L ⟼ Node)
Move = 𝐍 × H
Continuation = 𝒫(V) × ([H] ⟼ [V] ⟼ Leaf)
Continuation = 𝒫(V) × ([H]×𝒫(H) ⟼ [V] ⟼ Leaf)
Leaf = 𝒫(V) × ([H] ⟼ Handler)
Handler = Bag([V]) × 𝒫(Callback)
Callback = EventType -> [V] -> V
Callback = EventType → [V] → V
EventType ::= "+" | "-" | "!"
Bag(τ) = τ ⟼ 𝐍 -- bag of τ values
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
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
event handlers that may match the assertion being considered. Further
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
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`
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
`Continuation`; the map from path list to `Handler` in each `Leaf`;
and the `Bag([V])` in every `Handler`. This reflects the fact that the
index directly reflects the current state of the dataspace it is
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
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
cases where handlers are dynamically installed.
**Definition.** The `project` function extracts the subvalue at a
given path `h` from an overall value `v`.
**Example.** Let our pattern be
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 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
subvalues.
**Definition.** The `projectMany` partial function projects a sequence
of subvalues.
projectMany :: V -> [H] -> V
projectMany v [h_0, ...] = [project v h_0, ...]
projectMany :: V → [H] ⇀ [V]
projectMany v [h, ...] = [project v h, ...]
**Definition.** The `classof` function extracts the constructor label
`x` from a value `v`, yielding `()` if `v` is not a record.
**Definition.** The `classof` partial function extracts the constructor
label `x` from a record value. It is undefined for non-record values.
classof :: V -> 1 + Class
classof a = ()
classof x(v_0, ..., v_i) = x
classof :: V ⇀ L
classof x(v₀, ..., vᵢ) = x
**Definition.** The `extend` procedure augments an index with shape
information `s`, by imperatively updating the index structure. It
returns the `Continuation` associated with the deepest `Node`
visited in the path described by `s`.
information `s`, where `∃p . s = shape p`, by imperatively updating
the index structure. It returns the `Continuation` associated with the
final `Node` visited in the path described by `s`.
extend :: Node -> S -> Continuation
extend node s =
let (_, (cont, _)) = walk-node [] node 0 0 s
cont
extend :: Index → S → Continuation
extend (_, root) s = visit [] root (shapeVisit s)
where
walk-edge :: H -> Node -> 𝐍 -> 𝐍 -> [S] -> (𝐍,Node)
walk-edge h node n_pop n_index [] =
(n_pop + 1, node)
walk-edge h node n_pop n_index (s:shapes) =
let (n_pop', node') = walk-node h node n_pop n_index s
let n_index' = n_index + 1
let h' = (dropRight h 1) ++ [n_index']
walk-edge h' node' n_pop' n_index' shapes
walk-node :: H -> Node -> 𝐍 -> 𝐍 -> S -> (𝐍,Node)
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]
visit :: H → Node → [Move × L] → Continuation
visit h (cont, moveTable) [] = cont
visit h (cont, moveTable) ([(h̅, ℓ)] ++ moves) =
if h̅ not in moveTable then
moveTable[h̅] := {}
let classTable = moveTable[h̅]
if ℓ not in classTable then
let vs = { v | v ∈ fst cont,
classof (project v (h ⊕ h̅)) = ℓ }
classTable[ℓ] := ((vs, {}), {})
visit (h ⊕ h̅) classTable[ℓ] moves
**Definition.** The `addHandler` procedure installs into an index an
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
index.[^function-pointer-equality]
addHandler :: Index -> (S × [H×V] × [H]) -> Callback -> 1
addHandler :: Index → K → Callback → 1
addHandler index (s, constantMap, captureMap) f =
let (_, root) = index
let (cache, table) = extend root s
let constLocs = [h | (h,v) ∈ constantMap]
if constLocs not in table then
table[constLocs] := {}
let (cache, table) = extend index s
let (unsortedConstants, checks) = constantchecks constantMap
let constants = sort lexLt unsortedConstants
let constLocs = map fst constants
let constKey = (constLocs, checks)
if constKey not in table then
table[constKey] := {}
for v in cache
let key = projectMany v constLocs
if key not in table[constLocs] then
table[constLocs][key] := ({}, {})
let (leafcache, _leaftable) = table[constLocs][key]
leafcache += v
let constVals = [v | (h,v) ∈ constantMap]
if constVals not in table[constLocs] then
table[constLocs][constVals] := ({}, {})
let (leafcache, leaftable) = table[constLocs][constVals]
if ∀h ∈ checks, project v h is defined and
∃key . key = projectMany v constLocs then
if key not in table[constKey] then
table[constKey][key] := ({}, {})
let (leafcache, _leaftable) = table[constKey][key]
leafcache += v
let constVals = map snd constants
if constVals not in table[constKey] then
table[constKey][constVals] := ({}, {})
let (leafcache, leaftable) = table[constKey][constVals]
if captureMap not in leaftable then
let bag = empty_bag
for v in leafcache
bag[projectMany v captureMap] += 1
if ∃seq . seq = projectMany v captureMap then
bag[seq] += 1
leaftable[captureMap] := (bag, {})
let (bag, f_table) = leaftable[captureMap]
f_table += f
for seq in bag
for (seq ⟼ _) in bag
f "+" seq
()
@ -340,17 +446,19 @@ cases where handlers are dynamically installed.
**Definition.** The `removeHandler` procedure removes an event handler
from an index.
removeHandler :: Index -> (S × [H×V] × [H]) -> Callback -> 1
removeHandler :: Index → K → Callback → 1
removeHandler index (s, constantMap, captureMap) f =
let (_, root) = index
let (cache, table) = extend root s
let constLocs = [h | (h,v) ∈ constantMap]
if constLocs not in table then
let (_, table) = extend index s
let (unsortedConstants, checks) = constantchecks constantMap
let constants = sort lexLt unsortedConstants
let constLocs = map fst constants
let constKey = (constLocs, checks)
if constKey not in table then
return
let constVals = [v | (h,v) ∈ constantMap]
if constVals not in table[constLocs] then
let constVals = map snd constants
if constVals not in table[constKey] then
return
let (leafcache, leaftable) = table[constLocs][constVals]
let (leafcache, leaftable) = table[constKey][constVals]
if captureMap not in leaftable then
return
let (bag, f_table) = leaftable[captureMap]
@ -360,9 +468,9 @@ cases where handlers are dynamically installed.
if f_table = {} then
delete leaftable[captureMap]
if leafcache = {} and leaftable = {} then
delete table[constLocs][constVals]
if table[constLocs] = {} then
delete table[constLocs]
delete table[constKey][constVals]
if table[constKey] = {} then
delete table[constKey]
#### Adding assertions, removing assertions and sending messages
@ -377,70 +485,59 @@ parameterized with different update procedures.
Operation = { AddAssertion, RemoveAssertion, SendMessage }
modify :: Node ->
Operation ->
V ->
(Continuation -> V -> 1) ->
(Leaf -> V -> 1) ->
(Handler -> [V] -> 1) ->
modify :: Index →
Operation →
V →
(Continuation → V → 1) →
(Leaf → V → 1) →
(Handler → [V] → 1) →
1
modify node operation v m_cont m_leaf m_handler =
walk-node node [outermost(v)]
modify (_, root) operation v m_cont m_leaf m_handler =
visit root [v]
where
walk-node :: Node -> [V] -> 1
walk-node (cont, edges) vs =
walk-cont cont
for sel@(n_pop, n_index) in edges
let vs' = dropLeft vs n_pop
let (x(v_0, ...) : _) = vs'
let v' = v_{n_index}
if classof v' in edges[sel] then
walk-node edges[sel][classof v'] (v':vs')
visit :: Node → [V] → 1
visit (cont, moveTable) vs =
visit-cont cont
for ((n, h) ⟼ classTable) in moveTable
let (v' : vs') = dropLeft vs n in
if ∃v . v = project v' h and
∃ℓ . ℓ = classof v and
∃next . (ℓ ⟼ next) ∈ classTable then
visit next (v : v' : vs')
walk-cont :: Continuation -> 1
walk-cont cont@(cache, table) =
visit-cont :: Continuation → 1
visit-cont cont@(_, table) =
m_cont cont v
for constLocs in table
let consts = projectMany v constLocs
if operation = AddAssertion and consts not in table[constLocs] then
table[constLocs][consts] := ({}, {})
if consts in table[constLocs] then
let leaf@(leafcache, leaftable) =
table[constLocs][consts]
m_leaf leaf v
for captureMap in leaftable
let handler = leaftable[captureMap]
let vs = projectMany v captureMap
m_handler handler vs
if operation = RemoveAssertion and leafcache = {} and leaftable = {} then
delete table[constLocs][consts]
if table[constLocs] = {} then
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.
for ((constLocs, checks) ⟼ constVals) in table
if ∀h ∈ checks, project v h is defined and
∃consts . consts = projectMany v constLocs then
if operation = AddAssertion and consts not in constVals then
constVals[consts] := ({}, {})
if consts in constVals then
let leaf@(leafcache, leaftable) = constVals[consts]
m_leaf leaf v
for (captureMap ⟼ handler) in leaftable
if ∃vs . vs = projectMany v captureMap then
m_handler handler vs
if operation = RemoveAssertion and leafcache = {} and leaftable = {} then
delete constVals[consts]
if constVals = {} then
delete table[(constLocs, checks)]
**Definition.** The procedure `adjustAssertion` updates the copy-count
associated with `v` in the given index, invoking callbacks as a
side-effect if this changes the observable contents of the
dataspace.
adjustAssertion :: Index -> V -> 𝐍 -> 1
adjustAssertion (cache, root) v delta =
adjustAssertion :: Index → V → 𝐍 → 1
adjustAssertion index@(cache, root) v delta =
let was_present = v in cache
cache[v] += delta
let is_present = v in cache
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
modify root RemoveAssertion v del_cont del_leaf del_handler
modify index RemoveAssertion v del_cont del_leaf del_handler
where
add_cont (cache, _) v = cache += 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,
respectively.
addAssertion :: Index -> V -> 1
addAssertion :: 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
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
event handlers in the given index.
sendMessage :: Index -> V -> 1
sendMessage :: Index → V → 1
sendMessage (_, root) v =
modify root SendMessage v send_cont send_leaf send_handler
where
@ -491,8 +588,32 @@ processed first, no glitch will be detected.
for f in f_table
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
### JIT compilation of shapes, constant checks, captures
TODO
### Static analysis of messages and assertions
Static analysis of expressions under `(send! ...)` and `(assert ...)`

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

@ -14,7 +14,7 @@
(provide-service [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)
(define event (embedded-value embedded-event))
(linked-thread

2
syndicate/drivers/tcp.rkt
View File

@ -23,7 +23,7 @@
(with-services [syndicate/drivers/stream]
(at ds
(during/spawn
(Observe (:pattern (StreamConnection ,_ ,_ (TcpLocal ,(DLit $host) ,(DLit $port)))) _)
(Observe (:pattern (StreamConnection ,_ ,_ (TcpLocal ,(Pattern-lit $host) ,(Pattern-lit $port)))) _)
#:name (TcpLocal 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)
(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"
seconds
(/ (current-inexact-milliseconds) 1000.0))

45
syndicate/pattern.rkt
View File

@ -13,8 +13,10 @@
:pattern
:parse
pattern->shape
pattern->constant-values
pattern->constant-paths
pattern->check-paths
pattern->capture-paths
!dump-registered-preserves-patterns!
@ -180,14 +182,14 @@
[id
(dollar-id? #'id)
(transform-binding (undollar #'id) #`(Pattern-DBind (DBind (Pattern-DDiscard (DDiscard)))))]
(transform-binding (undollar #'id) #`(Pattern-bind (Pattern-discard)))]
[($ id p)
(transform-binding #'id #`(Pattern-DBind (DBind #,(walk #'p))))]
(transform-binding #'id #`(Pattern-bind #,(walk #'p)))]
[id
(discard-id? #'id)
#`(Pattern-DDiscard (DDiscard))]
#`(Pattern-discard)]
[(c l (list-stx piece ...))
(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))
(match desc
[(Pattern-DCompound (or (DCompound-rec _ fields)
(DCompound-arr fields)))
(append* (for/list [(key (in-naturals)) (subdesc (in-list fields))]
[(Pattern-group type entries)
(append* (list (cons (reverse key-rev) type))
(for/list [((key subdesc) (in-hash entries))]
(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))]
(walk-node (cons key key-rev) subdesc)))]
[(Pattern-DBind (DBind subdesc))
[(Pattern-bind subdesc)
(append (capture-fn key-rev) (walk-node key-rev subdesc))]
[(Pattern-DDiscard (DDiscard))
'()]
[(Pattern-DLit (DLit value))
[(Pattern-discard)
(discard-fn key-rev)]
[(Pattern-lit value)
(lit-fn key-rev (->preserve value))])))
(define (pattern->constant-values desc)
(select-pattern-leaves desc
(lambda (key-rev) (list))
(lambda (key-rev) (list))
(lambda (key-rev value) (list value))))
(define (pattern->constant-paths desc)
(select-pattern-leaves desc
(lambda (key-rev) (list))
(lambda (key-rev) (list))
(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)
(select-pattern-leaves desc
(lambda (key-rev) (list (reverse key-rev)))
(lambda (key-rev) (list))
(lambda (key-rev value) (list))))
(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]))
(define (def-pattern name def)
(define discard `(,(N 'Pattern-DDiscard) (,(N 'DDiscard))))
(define discard `(,(N 'Pattern-discard)))
(define (pat-pattern p)
(match (unwrap p)
@ -73,8 +73,8 @@
[(SimplePattern-embedded _interface) discard]
[(SimplePattern-lit value)
(if (eq? value '...)
`(,(N 'Pattern-DLit) (,(N 'DLit) (quote (... ...))))
`(,(N 'Pattern-DLit) (,(N 'DLit) ',value)))]
`(,(N 'Pattern-lit) (quote (... ...)))
`(,(N 'Pattern-lit) ',value))]
[(SimplePattern-seqof pat) discard]
[(SimplePattern-setof 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.
;; Following a skeleton's structure leads to zero or more `SkCont`s.
;;
;; Skeleton = (skeleton-node SkCont (AListof SkSelector (MutableHash ConstructorSpec Skeleton)))
;; SkSelector = (skeleton-selector Nat Any)
;; Skeleton = (skeleton-node SkCont (AListof SkMove (MutableHash ConstructorSpec Skeleton)))
;; SkMove = (skeleton-move Nat (Listof Any))
;;
;; A `ConstructorSpec` specifies a record label with arity, or a list
;; arity, or a dictionary.
;; A `ConstructorSpec` specifies a record and its label, or a sequence,
;; 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-selector (pop-count key) #:transparent)
(struct skeleton-move (pop-count path) #:transparent)
;;
;; A `Pattern` is a pattern over assertions, following the schema of
;; the same name in schemas/dataspacePatterns.prs. Instances of
@ -57,7 +57,8 @@
;;
;; SkCont = (skeleton-continuation
;; (MutableHash Assertion #t)
;; (MutableHash SkProj (MutableHash SkKey SkConst)))
;; (MutableHash (constant-positions SkProj SkProj)
;; (MutableHash SkKey SkConst)))
;; SkConst = (skeleton-matched-constant
;; (MutableHash Assertion #t)
;; (MutableHash SkProj SkAcc))
@ -66,6 +67,7 @@
;; (MutableHasheq EntityRef (MutableHash SkKey Handle)))
;;
(struct skeleton-continuation (cache table) #:transparent)
(struct constant-positions (with-values required-to-exist) #:transparent)
(struct skeleton-matched-constant (cache table) #:transparent)
(struct skeleton-accumulator (cache peers) #:transparent)
;;
@ -106,15 +108,19 @@
(define (skcont-add! turn c pat ref)
(define cs (pattern->constant-paths pat))
(define ce (pattern->check-paths pat))
(define (classify-assertions)
(define cvt (make-hash))
(hash-for-each (skeleton-continuation-cache c)
(lambda (a _)
(define avs (apply-projection a cs))
(define sc (hash-ref! cvt avs make-empty-matched-constant))
(hash-set! (skeleton-matched-constant-cache sc) a #t)))
(unless (void? (apply-projection a ce))
(define avs (apply-projection a cs))
(unless (void? avs)
(define sc (hash-ref! cvt avs make-empty-matched-constant))
(hash-set! (skeleton-matched-constant-cache sc) a #t)))))
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 vs (pattern->capture-paths pat))
(define (make-accumulator)
@ -133,8 +139,9 @@
(and (hash-empty? cache) (hash-empty? table)))
(define (skcont-remove! turn c pat ref)
(define cs (pattern->constant-paths pat))
(define cvt (hash-ref (skeleton-continuation-table c) cs #f))
(define ck (constant-positions (pattern->constant-paths pat)
(pattern->check-paths pat)))
(define cvt (hash-ref (skeleton-continuation-table c) ck #f))
(when cvt
(define cv (pattern->constant-values pat))
(define sc (hash-ref cvt cv #f))
@ -150,65 +157,60 @@
(when (skeleton-matched-constant-empty? sc)
(hash-remove! cvt cv)))
(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)
(match ctor-spec
[(cons 'rec label)
[(GroupType-rec label)
(and (non-object-struct? term)
(equal? (struct-type-name (struct->struct-type term)) label))]
['arr
[(GroupType-arr)
(list? term)]
['dict
[(GroupType-dict)
(hash? term)]))
(define (subterm-matches-ctor-spec? 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 (walk-node! rev-path sk pop-count key pat)
(match pat
[(Pattern-DCompound compound-pat)
(define selector (skeleton-selector pop-count key))
(define table
(match (assoc selector (skeleton-node-edges sk))
[#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]))
(let visit ((h '()) (sk sk) (moves (shape->visit (pattern->shape pat))))
(match moves
['() sk]
[(cons (cons move ctor-spec) moves)
(define table (skeleton-node-edge-table! sk move))
(define path (⊕ h move))
(define (make-skeleton-node-with-cache)
(define unfiltered (skeleton-continuation-cache (skeleton-node-continuation sk)))
(define filtered (make-hash))
(define path (reverse rev-path))
(hash-for-each unfiltered
(lambda (a _)
(when (subterm-matches-ctor-spec? a path ctor-spec)
(hash-set! filtered a #t))))
(make-empty-skeleton/cache filtered))
(define next (hash-ref! table ctor-spec make-skeleton-node-with-cache))
(let-values (((pop-count sk)
(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))
(visit path next moves)])))
(define (add-interest! turn sk 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))
(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)
(modify-skcont! continuation term0)
(let ((sct (skeleton-continuation-table continuation))
(constant-projections-to-remove '()))
(hash-for-each sct
(lambda (constant-proj key-proj-handler)
(define constants (apply-projection term0 constant-proj))
(define proj-handler
(hash-ref key-proj-handler
constants
(lambda () (on-missing-skconst key-proj-handler constants))))
(when proj-handler
(when (eq? (modify-skconst! proj-handler term0) 'remove-check)
(when (skeleton-matched-constant-empty? proj-handler)
(hash-remove! key-proj-handler constants)
(when (hash-empty? key-proj-handler)
(set! constant-projections-to-remove
(cons constant-proj constant-projections-to-remove)))))
(hash-for-each (skeleton-matched-constant-table proj-handler)
(lambda (variable-proj acc)
(define vars (apply-projection term0 variable-proj))
(modify-skacc! turn acc vars term0))))))
(for-each (lambda (constant-proj) (hash-remove! sct constant-proj))
constant-projections-to-remove))
(constant-keys-to-remove '()))
(for [((constant-key key-proj-handler) (in-hash sct))]
(unless (void? (apply-projection term0 (constant-positions-required-to-exist constant-key)))
(define constants (apply-projection term0 (constant-positions-with-values constant-key)))
(unless (void? constants)
(define proj-handler
(hash-ref key-proj-handler
constants
(lambda () (on-missing-skconst key-proj-handler constants))))
(when proj-handler
(when (eq? (modify-skconst! proj-handler term0) 'remove-check)
(when (skeleton-matched-constant-empty? proj-handler)
(hash-remove! key-proj-handler constants)
(when (hash-empty? key-proj-handler)
(set! constant-keys-to-remove (cons constant-key constant-keys-to-remove)))))
(hash-for-each (skeleton-matched-constant-table proj-handler)
(lambda (variable-proj acc)
(define vars (apply-projection term0 variable-proj))
(modify-skacc! turn acc vars term0)))))))
(for [(constant-key (in-list constant-keys-to-remove))]
(hash-remove! sct constant-key)))
(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 old-top (car popped-stack))
(define new-top (step-term old-top key))
(define entry
(hash-ref table
(cond [(non-object-struct? new-top) (cons 'rec (struct-type-name
(struct->struct-type new-top)))]
[(list? new-top) 'arr]
[(hash? new-top) 'dict]
[else #f])
#f))
(define new-top (apply-projection-path old-top path))
(define ctor-spec (cond [(non-object-struct? new-top)
(GroupType-rec (struct-type-name
(struct->struct-type new-top)))]
[(list? new-top) (GroupType-arr)]
[(hash? new-top) (GroupType-dict)]
[else #f]))
(define entry (hash-ref table ctor-spec #f))
(when entry (walk-node! entry (cons new-top popped-stack))))))
(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`
(define (apply-projection term proj)
(for/list [(path (in-list proj))]
(apply-projection-path term path)))
(let/ec return
(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)
(for/fold [(term term)]

44
syndicate/smart-pattern.rkt
View File

@ -23,13 +23,28 @@
(require syndicate/schemas/dataspacePatterns)
(define (rec label pats) (Pattern-DCompound (DCompound-rec label pats)))
(define (arr pats) (Pattern-DCompound (DCompound-arr pats)))
(define (dict pats) (Pattern-DCompound (DCompound-dict pats)))
(define (items->entries pats)
(define-values (entries max-i)
(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 (arr* pats) (rec 'arr (list (arr pats))))
(define (dict* pats) (rec 'dict (list (dict pats))))
(define (entries->items entries on-missing)
(define max-key (apply max -1 (hash-keys entries)))
(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)
(let walk ((v (->preserve v)))
@ -37,18 +52,19 @@
[(record label fs) (rec label (map walk fs))]
[(? list? vs) (arr (map walk vs))]
[(? 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 (literal-pattern->literal p)
(let/ec return
(define (e->i e) (entries->items e (lambda () (return (void)))))
(let walk ((p p))
(match p
[(Pattern-DDiscard (DDiscard)) (return (void))]
[(Pattern-DBind (DBind pp)) (walk pp)]
[(Pattern-DLit (DLit a)) (->preserve a)]
[(Pattern-DCompound (DCompound-rec label ps)) (record label (map walk ps))]
[(Pattern-DCompound (DCompound-arr ps)) (map walk ps)]
[(Pattern-DCompound (DCompound-dict d)) (for/hash [((k pp) (in-hash d))]
(values k (walk pp)))]))))
[(Pattern-discard) (return (void))]
[(Pattern-bind pp) (walk pp)]
[(Pattern-lit a) (->preserve a)]
[(Pattern-group (GroupType-rec label) ps) (record label (map walk (e->i ps)))]
[(Pattern-group (GroupType-arr) ps) (map walk (e->i ps))]
[(Pattern-group (GroupType-dict) d) (for/hash [((k pp) (in-hash d))]
(values k (walk pp)))]))))