More ergonomic step/prepend for tries and patches
This commit is contained in:
parent
81e10632dd
commit
f486f93bd4
|
@ -22,6 +22,7 @@
|
||||||
limit-patch/routing-table
|
limit-patch/routing-table
|
||||||
patch-pruned-by
|
patch-pruned-by
|
||||||
patch-without-at-meta
|
patch-without-at-meta
|
||||||
|
patch-step
|
||||||
only-meta-tset
|
only-meta-tset
|
||||||
compute-aggregate-patch
|
compute-aggregate-patch
|
||||||
apply-patch
|
apply-patch
|
||||||
|
@ -148,6 +149,12 @@
|
||||||
(define (patch-without-at-meta p)
|
(define (patch-without-at-meta p)
|
||||||
(patch-pruned-by p at-meta-everything))
|
(patch-pruned-by p at-meta-everything))
|
||||||
|
|
||||||
|
;; Steps both added and removes sets
|
||||||
|
(define (patch-step p key)
|
||||||
|
(match-define (patch added removed) p)
|
||||||
|
(patch (trie-step added key)
|
||||||
|
(trie-step removed key)))
|
||||||
|
|
||||||
(define only-meta-tset (datum-tset 'meta))
|
(define only-meta-tset (datum-tset 'meta))
|
||||||
|
|
||||||
;; Entries labelled with `label` may already exist in `base`; the
|
;; Entries labelled with `label` may already exist in `base`; the
|
||||||
|
|
|
@ -3,6 +3,7 @@
|
||||||
|
|
||||||
(provide non-object-struct?
|
(provide non-object-struct?
|
||||||
struct-type-name
|
struct-type-name
|
||||||
|
struct-type-constructor-arity
|
||||||
struct->struct-type)
|
struct->struct-type)
|
||||||
|
|
||||||
(require (only-in racket/class object?))
|
(require (only-in racket/class object?))
|
||||||
|
@ -20,9 +21,15 @@
|
||||||
(define-values (name x2 x3 x4 x5 x6 x7 x8) (struct-type-info st))
|
(define-values (name x2 x3 x4 x5 x6 x7 x8) (struct-type-info st))
|
||||||
name)
|
name)
|
||||||
|
|
||||||
|
;; StructType -> Natural
|
||||||
|
(define (struct-type-constructor-arity st)
|
||||||
|
(define-values (x1 arity x3 x4 x5 x6 x7 x8) (struct-type-info st))
|
||||||
|
arity)
|
||||||
|
|
||||||
;; Structure -> StructType
|
;; Structure -> StructType
|
||||||
;; Errors when given any struct that isn't completely transparent/prefab.
|
;; Errors when given any struct that isn't completely transparent/prefab.
|
||||||
(define (struct->struct-type p)
|
(define (struct->struct-type p)
|
||||||
(define-values (t skipped?) (struct-info p))
|
(define-values (t skipped?) (struct-info p))
|
||||||
(when skipped? (error 'struct->struct-type "Cannot reflect on struct instance ~v" p))
|
(when skipped? (error 'struct->struct-type "Cannot reflect on struct instance ~v" p))
|
||||||
t)
|
t)
|
||||||
|
|
||||||
|
|
|
@ -15,6 +15,7 @@
|
||||||
(rename-out [open-parenthesis <open-parenthesis>]
|
(rename-out [open-parenthesis <open-parenthesis>]
|
||||||
[canonical-open-parenthesis open-parenthesis])
|
[canonical-open-parenthesis open-parenthesis])
|
||||||
(except-out (struct-out open-parenthesis) open-parenthesis)
|
(except-out (struct-out open-parenthesis) open-parenthesis)
|
||||||
|
struct-type->parenthesis
|
||||||
|
|
||||||
?
|
?
|
||||||
wildcard?
|
wildcard?
|
||||||
|
@ -27,8 +28,7 @@
|
||||||
trie
|
trie
|
||||||
trie-empty?
|
trie-empty?
|
||||||
trie-non-empty?
|
trie-non-empty?
|
||||||
(rename-out [rsigma trie-prepend-atom])
|
trie-prepend
|
||||||
(rename-out [ropen trie-prepend-parenthesis])
|
|
||||||
|
|
||||||
pattern->trie*
|
pattern->trie*
|
||||||
pattern->trie
|
pattern->trie
|
||||||
|
@ -304,14 +304,28 @@
|
||||||
(define (canonical-open-parenthesis arity type)
|
(define (canonical-open-parenthesis arity type)
|
||||||
(canonicalize (open-parenthesis arity type)))
|
(canonicalize (open-parenthesis arity type)))
|
||||||
|
|
||||||
|
;; StructType -> OpenParenthesis
|
||||||
|
(define (struct-type->parenthesis st)
|
||||||
|
(canonical-open-parenthesis (struct-type-constructor-arity st) st))
|
||||||
|
|
||||||
|
;; OpenParenthesis Trie -> Trie
|
||||||
|
;; Prepends an open-parenthesis edge to r, if r is non-empty
|
||||||
|
(define (ropen* paren r)
|
||||||
|
(if (trie-empty? r)
|
||||||
|
r
|
||||||
|
(canonicalize (branch (treap-insert empty-omap paren r) trie-empty empty-smap))))
|
||||||
|
|
||||||
;; Natural ParenType Trie -> Trie
|
;; Natural ParenType Trie -> Trie
|
||||||
;; Prepends an open-parenthesis edge to r, if r is non-empty
|
;; Prepends an open-parenthesis edge to r, if r is non-empty
|
||||||
(define (ropen arity type r)
|
(define (ropen arity type r)
|
||||||
(if (trie-empty? r)
|
(ropen* (canonical-open-parenthesis arity type) r))
|
||||||
r
|
|
||||||
(canonicalize (branch (treap-insert empty-omap (canonical-open-parenthesis arity type) r)
|
;; (U Sigma OpenParenthesis) Trie -> Trie
|
||||||
trie-empty
|
;; User-accessible rsigma / ropen*.
|
||||||
empty-smap))))
|
(define (trie-prepend key r)
|
||||||
|
(if (open-parenthesis? key)
|
||||||
|
(ropen* key r)
|
||||||
|
(rsigma (canonicalize key) r)))
|
||||||
|
|
||||||
;; Natural Trie -> Trie
|
;; Natural Trie -> Trie
|
||||||
;; Prepends n wildcard edges to r, if r is non-empty.
|
;; Prepends n wildcard edges to r, if r is non-empty.
|
||||||
|
|
Loading…
Reference in New Issue