111 lines
4.0 KiB
Racket
111 lines
4.0 KiB
Racket
#lang racket/base
|
|
;;; SPDX-License-Identifier: LGPL-3.0-or-later
|
|
;;; SPDX-FileCopyrightText: Copyright © 2021-2022 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 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 (Attenuation attenuation)))
|
|
(match-define (embedded v) (walk t))
|
|
(embedded (apply attenuate-entity-ref v attenuation))]
|
|
[(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)]))
|
|
|
|
;; TODO: prove to myself I've gotten the order correct. (Right-to-left, wasn't it?!?!)
|
|
(define (run-rewrites attenuation v)
|
|
(let loop ((stages attenuation) (v v))
|
|
(match stages
|
|
['() v]
|
|
[(cons stage remaining) (match (examine-alternatives stage v)
|
|
[(? void?) (void)]
|
|
[rewritten (loop remaining rewritten)])])))
|
|
|
|
;; TODO: prove to myself I've gotten the order correct. (Right-to-left, wasn't it?!?!)
|
|
(define (attenuate-entity-ref r . caveats)
|
|
(match-define (entity-ref relay target previous-attenuation) r)
|
|
(if (null? caveats)
|
|
r
|
|
(entity-ref relay target (append previous-attenuation caveats))))
|