#lang racket/base
;;; SPDX-License-Identifier: LGPL-3.0-or-later
;;; SPDX-FileCopyrightText: Copyright © 2021 Tony Garnock-Jones <tonyg@leastfixedpoint.com>

(provide run-rewrites)

(require racket/match)
(require racket/dict)
(require preserves)

(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)]
      [(Pattern-PCompound (PCompound (ConstructorSpec-CRec (CRec label arity)) 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)) 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)) 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) bindings))

(define (instantiate-Template t bindings)
  (let walk ((t t))
    (match t
      [(Template-TRef (TRef name))
       (hash-ref bindings name (lambda () (error 'instantiate-Template "Missing binding: ~v" name)))]
      [(Template-Lit (Lit v)) v]
      [(Template-TCompound (TCompound (ConstructorSpec-CRec (CRec label arity)) 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)) 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)) 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)]))

(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)])])))