#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))))