124 lines
5.0 KiB
Racket
124 lines
5.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 (ConstructorSpec-CRec (CRec label arity))
|
|
(PCompoundMembers members)))
|
|
(match v
|
|
[(record (== label preserve=?) fields)
|
|
(and (= (length fields) arity)
|
|
(for/and [((key pp) (in-hash members))]
|
|
(and (exact-integer? key) (walk pp (list-ref fields key)))))]
|
|
[_ #f])]
|
|
[(Pattern-PCompound (PCompound (ConstructorSpec-CArr (CArr arity))
|
|
(PCompoundMembers members)))
|
|
(and (list? v)
|
|
(= (length v) arity)
|
|
(for/and [((key pp) (in-hash members))]
|
|
(and (exact-integer? key) (walk pp (list-ref v key)))))]
|
|
[(Pattern-PCompound (PCompound (ConstructorSpec-CDict (CDict))
|
|
(PCompoundMembers 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 (ConstructorSpec-CRec (CRec label arity))
|
|
(TCompoundMembers members)))
|
|
(record label
|
|
(for/list [(i (in-range 0 arity))]
|
|
(walk (hash-ref members i (lambda () (error 'instantiate-Template
|
|
"Missing record field key ~v" i))))))]
|
|
[(Template-TCompound (TCompound (ConstructorSpec-CArr (CArr arity))
|
|
(TCompoundMembers members)))
|
|
(for/list [(i (in-range 0 arity))]
|
|
(walk (hash-ref members i (lambda () (error 'instantiate-Template
|
|
"Missing array key ~v" i)))))]
|
|
[(Template-TCompound (TCompound (ConstructorSpec-CDict (CDict))
|
|
(TCompoundMembers 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))))
|