116 lines
4.0 KiB
Racket
116 lines
4.0 KiB
Racket
#lang racket/base
|
|
;;; SPDX-License-Identifier: LGPL-3.0-or-later
|
|
;;; SPDX-FileCopyrightText: Copyright © 2021-2023 Tony Garnock-Jones <tonyg@leastfixedpoint.com>
|
|
|
|
(provide run-rewrites
|
|
attenuate-entity-ref)
|
|
|
|
(require racket/match)
|
|
(require racket/dict)
|
|
(require preserves)
|
|
|
|
(require "entity-ref.rkt")
|
|
(require "schemas/sturdy.rkt")
|
|
|
|
(define (match-Pattern p v)
|
|
(define bindings-rev '())
|
|
|
|
(define (walk p v)
|
|
(match p
|
|
[(Pattern-PDiscard _) #t]
|
|
[(Pattern-PAtom (PAtom-Boolean)) (boolean? v)]
|
|
[(Pattern-PAtom (PAtom-ByteString)) (bytes? v)]
|
|
[(Pattern-PAtom (PAtom-Double)) (flonum? v)]
|
|
[(Pattern-PAtom (PAtom-Float)) (float? v)]
|
|
[(Pattern-PAtom (PAtom-SignedInteger)) (integer? v)]
|
|
[(Pattern-PAtom (PAtom-String)) (string? v)]
|
|
[(Pattern-PAtom (PAtom-Symbol)) (symbol? v)]
|
|
[(Pattern-PEmbedded (PEmbedded)) (embedded? v)]
|
|
[(Pattern-PBind (PBind p))
|
|
(and (walk p v)
|
|
(begin (set! bindings-rev (cons v bindings-rev))
|
|
#t))]
|
|
[(Pattern-PAnd (PAnd ps)) (andmap (lambda (p) (walk p v)) ps)]
|
|
[(Pattern-PNot p)
|
|
(let ((saved bindings-rev))
|
|
(set! bindings-rev '())
|
|
(let ((result (walk p v)))
|
|
(set! bindings-rev saved)
|
|
(not result)))]
|
|
[(Pattern-Lit (Lit expected)) (preserve=? expected v)]
|
|
[(Pattern-PCompound (PCompound-rec label field-pats))
|
|
(match v
|
|
[(record (== label preserve=?) fields)
|
|
(and (= (length fields) (length field-pats))
|
|
(andmap walk field-pats fields))]
|
|
[_ #f])]
|
|
[(Pattern-PCompound (PCompound-arr item-pats))
|
|
(and (list? v)
|
|
(= (length v) (length item-pats))
|
|
(andmap walk item-pats v))]
|
|
[(Pattern-PCompound (PCompound-dict members))
|
|
(and (dict? v)
|
|
(for/and [((key pp) (in-hash members))]
|
|
(define vv (hash-ref v key (void)))
|
|
(and (not (void? vv)) (walk pp vv))))]))
|
|
|
|
(and (walk p v) (reverse bindings-rev)))
|
|
|
|
(define (instantiate-Template t bindings)
|
|
(let walk ((t t))
|
|
(match t
|
|
[(Template-TAttenuate (TAttenuate t caveats))
|
|
(match-define (embedded v) (walk t))
|
|
(embedded (apply attenuate-entity-ref v caveats))]
|
|
[(Template-TRef (TRef index))
|
|
(if (< index (length bindings))
|
|
(list-ref bindings index)
|
|
(error 'instantiate-Template "Binding index out of range: ~v" index))]
|
|
[(Template-Lit (Lit v)) v]
|
|
[(Template-TCompound (TCompound-rec label field-templates))
|
|
(record label (map walk field-templates))]
|
|
[(Template-TCompound (TCompound-arr item-templates))
|
|
(map walk item-templates)]
|
|
[(Template-TCompound (TCompound-dict members))
|
|
(for/hash [((key tt) (in-hash members))]
|
|
(values key (walk tt)))])))
|
|
|
|
(define (rewrite r v)
|
|
(define bindings (match-Pattern (Rewrite-pattern r) v))
|
|
(if bindings
|
|
(instantiate-Template (Rewrite-template r) bindings)
|
|
(void)))
|
|
|
|
(define (examine-alternatives caveat v)
|
|
(match caveat
|
|
[(Caveat-Alts (Alts alts))
|
|
(let loop ((alts alts))
|
|
(match alts
|
|
['() (void)]
|
|
[(cons alt remaining) (match (rewrite alt v)
|
|
[(? void?) (loop remaining)]
|
|
[rewritten rewritten])]))]
|
|
[(Caveat-Rewrite r)
|
|
(rewrite r v)]
|
|
[(Caveat-Reject (Reject pattern))
|
|
(if (match-Pattern pattern v)
|
|
(void)
|
|
v)]
|
|
[(Caveat-unknown v)
|
|
(void)]))
|
|
|
|
(define (run-rewrites caveats v)
|
|
(let/ec return
|
|
(foldr (lambda (c v) (match (examine-alternatives c v)
|
|
[(? void?) (return (void))]
|
|
[rewritten rewritten]))
|
|
v
|
|
caveats)))
|
|
|
|
;; 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)
|
|
(if (null? caveats)
|
|
r
|
|
(struct-copy entity-ref r [attenuation (append (entity-ref-attenuation r) caveats)])))
|