2021-05-27 08:36:35 +00:00
|
|
|
#lang racket/base
|
2021-06-04 14:20:14 +00:00
|
|
|
;;; SPDX-License-Identifier: LGPL-3.0-or-later
|
|
|
|
;;; SPDX-FileCopyrightText: Copyright © 2021 Tony Garnock-Jones <tonyg@leastfixedpoint.com>
|
2021-05-27 08:36:35 +00:00
|
|
|
|
2021-06-09 13:06:58 +00:00
|
|
|
(provide run-rewrites
|
|
|
|
attenuate-entity-ref)
|
2021-05-27 08:36:35 +00:00
|
|
|
|
|
|
|
(require racket/match)
|
|
|
|
(require racket/dict)
|
|
|
|
(require preserves)
|
|
|
|
|
2021-06-09 13:06:58 +00:00
|
|
|
(require "entity-ref.rkt")
|
2021-05-27 08:36:35 +00:00
|
|
|
(require "schemas/gen/sturdy.rkt")
|
|
|
|
|
|
|
|
(define (match-Pattern p v)
|
|
|
|
(define bindings (make-hasheq))
|
|
|
|
|
|
|
|
(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 n p)) (and (walk p v) (begin (hash-set! bindings n v) #t))]
|
|
|
|
[(Pattern-PAnd ps) (andmap (lambda (p) (walk p v)) ps)]
|
|
|
|
[(Pattern-PNot p)
|
|
|
|
(let ((saved bindings))
|
|
|
|
(set! bindings (make-hasheq))
|
|
|
|
(let ((result (walk p v)))
|
|
|
|
(set! bindings saved)
|
|
|
|
(not result)))]
|
|
|
|
[(Pattern-Lit (Lit expected)) (preserve=? expected v)]
|
2021-06-09 12:53:08 +00:00
|
|
|
[(Pattern-PCompound (PCompound (ConstructorSpec-CRec (CRec label arity))
|
|
|
|
(PCompoundMembers members)))
|
2021-05-27 08:36:35 +00:00
|
|
|
(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])]
|
2021-06-09 12:53:08 +00:00
|
|
|
[(Pattern-PCompound (PCompound (ConstructorSpec-CArr (CArr arity))
|
|
|
|
(PCompoundMembers members)))
|
2021-05-27 08:36:35 +00:00
|
|
|
(and (list? v)
|
|
|
|
(= (length v) arity)
|
|
|
|
(for/and [((key pp) (in-hash members))]
|
|
|
|
(and (exact-integer? key) (walk pp (list-ref v key)))))]
|
2021-06-09 12:53:08 +00:00
|
|
|
[(Pattern-PCompound (PCompound (ConstructorSpec-CDict (CDict))
|
|
|
|
(PCompoundMembers members)))
|
2021-05-27 08:36:35 +00:00
|
|
|
(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) bindings))
|
|
|
|
|
|
|
|
(define (instantiate-Template t bindings)
|
|
|
|
(let walk ((t t))
|
|
|
|
(match t
|
2021-06-09 13:06:58 +00:00
|
|
|
[(Template-TAttenuate (TAttenuate t (Attenuation attenuation)))
|
|
|
|
(match-define (embedded v) (walk t))
|
|
|
|
(embedded (apply attenuate-entity-ref v attenuation))]
|
2021-05-27 08:36:35 +00:00
|
|
|
[(Template-TRef (TRef name))
|
|
|
|
(hash-ref bindings name (lambda () (error 'instantiate-Template "Missing binding: ~v" name)))]
|
|
|
|
[(Template-Lit (Lit v)) v]
|
2021-06-09 12:53:08 +00:00
|
|
|
[(Template-TCompound (TCompound (ConstructorSpec-CRec (CRec label arity))
|
|
|
|
(TCompoundMembers members)))
|
2021-05-27 08:36:35 +00:00
|
|
|
(record label
|
|
|
|
(for/list [(i (in-range 0 arity))]
|
|
|
|
(walk (hash-ref members i (lambda () (error 'instantiate-Template
|
|
|
|
"Missing record field key ~v" i))))))]
|
2021-06-09 12:53:08 +00:00
|
|
|
[(Template-TCompound (TCompound (ConstructorSpec-CArr (CArr arity))
|
|
|
|
(TCompoundMembers members)))
|
2021-05-27 08:36:35 +00:00
|
|
|
(for/list [(i (in-range 0 arity))]
|
|
|
|
(walk (hash-ref members i (lambda () (error 'instantiate-Template
|
|
|
|
"Missing array key ~v" i)))))]
|
2021-06-09 12:53:08 +00:00
|
|
|
[(Template-TCompound (TCompound (ConstructorSpec-CDict (CDict))
|
|
|
|
(TCompoundMembers members)))
|
2021-05-27 08:36:35 +00:00
|
|
|
(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)]))
|
|
|
|
|
2021-06-08 07:21:54 +00:00
|
|
|
;; TODO: prove to myself I've gotten the order correct. (Right-to-left, wasn't it?!?!)
|
2021-05-27 08:36:35 +00:00
|
|
|
(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)])])))
|
2021-06-09 13:06:58 +00:00
|
|
|
|
|
|
|
;; 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))))
|