Repair and update attenuation processing
This commit is contained in:
parent
b213d90d3c
commit
cc7ec64815
|
@ -17,8 +17,7 @@
|
||||||
(at ds
|
(at ds
|
||||||
(during (Bind (SturdyRef-oid unvalidated-sturdyref) $key $target)
|
(during (Bind (SturdyRef-oid unvalidated-sturdyref) $key $target)
|
||||||
(define sturdyref (validate unvalidated-sturdyref key))
|
(define sturdyref (validate unvalidated-sturdyref key))
|
||||||
(define attenuation
|
(define attenuation (SturdyRef-caveatChain sturdyref))
|
||||||
(append-map Attenuation-value (reverse (SturdyRef-caveatChain sturdyref))))
|
|
||||||
(define attenuated-target (apply attenuate-entity-ref target attenuation))
|
(define attenuated-target (apply attenuate-entity-ref target attenuation))
|
||||||
(at observer (assert (embedded attenuated-target)))))]))
|
(at observer (assert (embedded attenuated-target)))))]))
|
||||||
|
|
||||||
|
|
|
@ -27,7 +27,7 @@
|
||||||
|
|
||||||
))
|
))
|
||||||
|
|
||||||
(define build-deps '("rackunit-lib"))
|
(define build-deps '("rackunit-lib" "at-exp-lib"))
|
||||||
|
|
||||||
(define pre-install-collection "private/install.rkt")
|
(define pre-install-collection "private/install.rkt")
|
||||||
|
|
||||||
|
|
|
@ -30,7 +30,7 @@
|
||||||
(and (walk p v)
|
(and (walk p v)
|
||||||
(begin (set! bindings-rev (cons v bindings-rev))
|
(begin (set! bindings-rev (cons v bindings-rev))
|
||||||
#t))]
|
#t))]
|
||||||
[(Pattern-PAnd ps) (andmap (lambda (p) (walk p v)) ps)]
|
[(Pattern-PAnd (PAnd ps)) (andmap (lambda (p) (walk p v)) ps)]
|
||||||
[(Pattern-PNot p)
|
[(Pattern-PNot p)
|
||||||
(let ((saved bindings-rev))
|
(let ((saved bindings-rev))
|
||||||
(set! bindings-rev '())
|
(set! bindings-rev '())
|
||||||
|
@ -59,9 +59,9 @@
|
||||||
(define (instantiate-Template t bindings)
|
(define (instantiate-Template t bindings)
|
||||||
(let walk ((t t))
|
(let walk ((t t))
|
||||||
(match t
|
(match t
|
||||||
[(Template-TAttenuate (TAttenuate t (Attenuation attenuation)))
|
[(Template-TAttenuate (TAttenuate t caveats))
|
||||||
(match-define (embedded v) (walk t))
|
(match-define (embedded v) (walk t))
|
||||||
(embedded (apply attenuate-entity-ref v attenuation))]
|
(embedded (apply attenuate-entity-ref v caveats))]
|
||||||
[(Template-TRef (TRef index))
|
[(Template-TRef (TRef index))
|
||||||
(if (< index (length bindings))
|
(if (< index (length bindings))
|
||||||
(list-ref bindings index)
|
(list-ref bindings index)
|
||||||
|
@ -91,20 +91,25 @@
|
||||||
[(? void?) (loop remaining)]
|
[(? void?) (loop remaining)]
|
||||||
[rewritten rewritten])]))]
|
[rewritten rewritten])]))]
|
||||||
[(Caveat-Rewrite r)
|
[(Caveat-Rewrite r)
|
||||||
(rewrite r v)]))
|
(rewrite r v)]
|
||||||
|
[(Caveat-Reject (Reject pattern))
|
||||||
|
(if (match-Pattern pattern v)
|
||||||
|
(void)
|
||||||
|
v)]
|
||||||
|
[(Caveat-unknown v)
|
||||||
|
(void)]))
|
||||||
|
|
||||||
;; TODO: prove to myself I've gotten the order correct. (Right-to-left, wasn't it?!?!)
|
(define (run-rewrites caveats v)
|
||||||
(define (run-rewrites attenuation v)
|
(let/ec return
|
||||||
(let loop ((stages attenuation) (v v))
|
(foldr (lambda (c v) (match (examine-alternatives c v)
|
||||||
(match stages
|
[(? void?) (return (void))]
|
||||||
['() v]
|
[rewritten rewritten]))
|
||||||
[(cons stage remaining) (match (examine-alternatives stage v)
|
v
|
||||||
[(? void?) (void)]
|
caveats)))
|
||||||
[rewritten (loop remaining rewritten)])])))
|
|
||||||
|
|
||||||
;; TODO: prove to myself I've gotten the order correct. (Right-to-left, wasn't it?!?!)
|
;; Extends `r` with `caveats`, which are appended, in the order given, to the sequence of
|
||||||
|
;; caveats already in `r`, if any.
|
||||||
(define (attenuate-entity-ref r . caveats)
|
(define (attenuate-entity-ref r . caveats)
|
||||||
(match-define (entity-ref relay target previous-attenuation) r)
|
|
||||||
(if (null? caveats)
|
(if (null? caveats)
|
||||||
r
|
r
|
||||||
(entity-ref relay target (append previous-attenuation caveats))))
|
(struct-copy entity-ref r [attenuation (append (entity-ref-attenuation r) caveats)])))
|
||||||
|
|
|
@ -51,18 +51,17 @@
|
||||||
(define (mint oid key)
|
(define (mint oid key)
|
||||||
(SturdyRef oid '() (signature key (sturdy-encode oid))))
|
(SturdyRef oid '() (signature key (sturdy-encode oid))))
|
||||||
|
|
||||||
(define (attenuate-sturdy r . attenuation)
|
(define (update-signature sig caveats)
|
||||||
|
(for/fold [(sig sig)] [(caveat (in-list caveats))]
|
||||||
|
(signature sig (sturdy-encode (->preserve caveat)))))
|
||||||
|
|
||||||
|
(define (attenuate-sturdy r . caveats)
|
||||||
(match-define (SturdyRef oid caveatChain sig) r)
|
(match-define (SturdyRef oid caveatChain sig) r)
|
||||||
(SturdyRef oid
|
(SturdyRef oid (append caveatChain caveats) (update-signature sig caveats)))
|
||||||
(append caveatChain (list attenuation))
|
|
||||||
(signature sig (sturdy-encode (->preserve attenuation)))))
|
|
||||||
|
|
||||||
(define (SturdyRef-valid? r key)
|
(define (SturdyRef-valid? r key)
|
||||||
(match-define (SturdyRef oid caveatChain actual-sig) r)
|
(match-define (SturdyRef oid caveatChain actual-sig) r)
|
||||||
(define expected-sig
|
(define expected-sig (update-signature (signature key (sturdy-encode oid)) caveatChain))
|
||||||
(for/fold [(sig (signature key (sturdy-encode oid)))]
|
|
||||||
[(attenuation (in-list caveatChain))]
|
|
||||||
(signature sig (sturdy-encode (->preserve attenuation)))))
|
|
||||||
(equal? expected-sig actual-sig))
|
(equal? expected-sig actual-sig))
|
||||||
|
|
||||||
(define (validate r key)
|
(define (validate r key)
|
||||||
|
|
|
@ -0,0 +1,71 @@
|
||||||
|
#lang at-exp racket/base
|
||||||
|
;;; SPDX-License-Identifier: LGPL-3.0-or-later
|
||||||
|
;;; SPDX-FileCopyrightText: Copyright © 2023 Tony Garnock-Jones <tonyg@leastfixedpoint.com>
|
||||||
|
|
||||||
|
(module+ test
|
||||||
|
(require rackunit)
|
||||||
|
(require syndicate/rewrite)
|
||||||
|
(require syndicate/entity-ref)
|
||||||
|
(require syndicate/schemas/sturdy)
|
||||||
|
(require preserves)
|
||||||
|
|
||||||
|
(define (C . strings) (parse-Caveat (string->preserve (apply string-append strings))))
|
||||||
|
|
||||||
|
(define e0 (entity-ref 'dummy-facet 'dummy-entity '()))
|
||||||
|
|
||||||
|
;; Allows only 'yes, 'no, and (list x y) through.
|
||||||
|
(define c1 @C{<or [<rewrite <and [<bind <_>> <lit yes>]> <ref 0>>
|
||||||
|
<rewrite <and [<bind <_>> <lit no>]> <ref 0>>
|
||||||
|
<rewrite <and [<bind <_>> <arr [<_> <_>]>]> <ref 0>>]>})
|
||||||
|
|
||||||
|
;; Changes (list x y) into (list 'swapped y x), leaves everything else alone.
|
||||||
|
(define c2 @C{<or [<rewrite <arr [<bind <_>> <bind <_>>]> <arr [<lit swapped> <ref 1> <ref 0>]>>
|
||||||
|
<rewrite <bind <_>> <ref 0>>]>})
|
||||||
|
|
||||||
|
;; Rejects 'no.
|
||||||
|
(define c3 @C{<reject <lit no>>})
|
||||||
|
|
||||||
|
;; An unknown caveat.
|
||||||
|
(define c4 @C{<caveat-from-the-year-3000>})
|
||||||
|
|
||||||
|
(define e1 (attenuate-entity-ref e0 c1))
|
||||||
|
|
||||||
|
(check-equal? (run-rewrites (entity-ref-attenuation e1) 'yes) 'yes)
|
||||||
|
(check-equal? (run-rewrites (entity-ref-attenuation e1) 'no) 'no)
|
||||||
|
(check-equal? (run-rewrites (entity-ref-attenuation e1) '(1 2)) '(1 2))
|
||||||
|
(check-equal? (run-rewrites (entity-ref-attenuation e1) '(1 2 3)) (void))
|
||||||
|
(check-equal? (run-rewrites (entity-ref-attenuation e1) "yes") (void))
|
||||||
|
|
||||||
|
(define e12 (attenuate-entity-ref e1 c2))
|
||||||
|
|
||||||
|
(check-equal? (run-rewrites (entity-ref-attenuation e12) 'yes) 'yes)
|
||||||
|
(check-equal? (run-rewrites (entity-ref-attenuation e12) 'no) 'no)
|
||||||
|
(check-equal? (run-rewrites (entity-ref-attenuation e12) '(1 2)) (void))
|
||||||
|
(check-equal? (run-rewrites (entity-ref-attenuation e12) '(1 2 3)) (void))
|
||||||
|
(check-equal? (run-rewrites (entity-ref-attenuation e12) "yes") (void))
|
||||||
|
|
||||||
|
(define e21 (attenuate-entity-ref e0 c2 c1))
|
||||||
|
|
||||||
|
(check-equal? (run-rewrites (entity-ref-attenuation e21) 'yes) 'yes)
|
||||||
|
(check-equal? (run-rewrites (entity-ref-attenuation e21) 'no) 'no)
|
||||||
|
(check-equal? (run-rewrites (entity-ref-attenuation e21) '(1 2)) '(swapped 2 1))
|
||||||
|
(check-equal? (run-rewrites (entity-ref-attenuation e21) '(1 2 3)) (void))
|
||||||
|
(check-equal? (run-rewrites (entity-ref-attenuation e21) "yes") (void))
|
||||||
|
|
||||||
|
(define e123 (attenuate-entity-ref e12 c3))
|
||||||
|
|
||||||
|
(check-equal? (run-rewrites (entity-ref-attenuation e123) 'yes) 'yes)
|
||||||
|
(check-equal? (run-rewrites (entity-ref-attenuation e123) 'no) (void))
|
||||||
|
(check-equal? (run-rewrites (entity-ref-attenuation e123) '(1 2)) (void))
|
||||||
|
(check-equal? (run-rewrites (entity-ref-attenuation e123) '(1 2 3)) (void))
|
||||||
|
(check-equal? (run-rewrites (entity-ref-attenuation e123) "yes") (void))
|
||||||
|
|
||||||
|
(define e4 (attenuate-entity-ref e0 c4))
|
||||||
|
|
||||||
|
(check-equal? (run-rewrites (entity-ref-attenuation e4) 'yes) (void))
|
||||||
|
(check-equal? (run-rewrites (entity-ref-attenuation e4) 'no) (void))
|
||||||
|
(check-equal? (run-rewrites (entity-ref-attenuation e4) '(1 2)) (void))
|
||||||
|
(check-equal? (run-rewrites (entity-ref-attenuation e4) '(1 2 3)) (void))
|
||||||
|
(check-equal? (run-rewrites (entity-ref-attenuation e4) "yes") (void))
|
||||||
|
|
||||||
|
)
|
|
@ -0,0 +1,29 @@
|
||||||
|
#lang at-exp racket/base
|
||||||
|
;;; SPDX-License-Identifier: LGPL-3.0-or-later
|
||||||
|
;;; SPDX-FileCopyrightText: Copyright © 2023 Tony Garnock-Jones <tonyg@leastfixedpoint.com>
|
||||||
|
|
||||||
|
(module+ test
|
||||||
|
(require rackunit)
|
||||||
|
(require syndicate/sturdy)
|
||||||
|
(require preserves)
|
||||||
|
|
||||||
|
(define (C . strings) (parse-SturdyRef (string->preserve (apply string-append strings))))
|
||||||
|
|
||||||
|
(define s0 (mint "test" #""))
|
||||||
|
|
||||||
|
(check-equal? s0 (SturdyRef "test" '() #"J\270\253\306N\365\2240\303\206\324\2G\306m\377"))
|
||||||
|
(check-true (SturdyRef-valid? s0 #""))
|
||||||
|
|
||||||
|
(define s1 (attenuate-sturdy s0 'a 'b 'c))
|
||||||
|
|
||||||
|
(check-equal? s1 (SturdyRef "test" '(a b c) #"oO\243\334\366aW6\5\303<\314St\275\226"))
|
||||||
|
(check-true (SturdyRef-valid? s1 #""))
|
||||||
|
(check-false (SturdyRef-valid?
|
||||||
|
(SturdyRef "test" '(a b c) #"pO\243\334\366aW6\5\303<\314St\275\226")
|
||||||
|
#""))
|
||||||
|
(check-false (SturdyRef-valid?
|
||||||
|
(SturdyRef "test" '(a c b) #"oO\243\334\366aW6\5\303<\314St\275\226")
|
||||||
|
#""))
|
||||||
|
|
||||||
|
)
|
||||||
|
|
Loading…
Reference in New Issue