72 lines
3.1 KiB
Racket
72 lines
3.1 KiB
Racket
#lang at-exp racket/base
|
|
;;; SPDX-License-Identifier: LGPL-3.0-or-later
|
|
;;; SPDX-FileCopyrightText: Copyright © 2023-2024 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))
|
|
|
|
)
|