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

(provide rec
         arr
         dict

         rec*
         arr*
         dict*

         literal->literal-pattern
         literal-pattern->literal
         lit)

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

(require preserves)
(require preserves-schema)

(require syndicate/schemas/dataspacePatterns)

(define (items->entries pats)
  (define npats (length pats))
  (define entries
    (for/fold [(entries (hash))] [(i (in-naturals)) (p (in-list pats))]
      (if (Pattern-discard? p) entries (hash-set entries i p))))
  (if (and (positive? npats) (not (hash-has-key? entries (- npats 1))))
      (hash-set entries (- npats 1) (Pattern-discard))
      entries))

(define (entries->items entries on-missing)
  (define max-key (apply max -1 (hash-keys entries)))
  (for/list [(i (in-range 0 (+ max-key 1)))]
    (hash-ref entries i on-missing)))

(define (rec label pats) (Pattern-group (GroupType-rec label) (items->entries pats)))
(define (arr pats) (Pattern-group (GroupType-arr) (items->entries pats)))
(define (dict pats) (Pattern-group (GroupType-dict) pats))

(define (rec* label pats) (rec 'group (list (rec 'rec (list (lit label))) (dict (items->entries pats)))))
(define (arr* pats) (rec 'group (list (rec 'arr (list)) (dict (items->entries pats)))))
(define (dict* pats) (rec 'group (list (rec 'dict (list)) (dict pats))))

(define (literal->literal-pattern v)
  (let walk ((v (->preserve v)))
    (match v
      [(record label fs) (rec label (map walk fs))]
      [(? list? vs) (arr (map walk vs))]
      [(? dict? d) (dict (for/hash [((k v) (in-hash d))] (values k (walk v))))]
      [other (Pattern-lit (parse-AnyAtom! other))])))

(define lit literal->literal-pattern)

(define (literal-pattern->literal p)
  (let/ec return
    (define (e->i e) (entries->items e (lambda () (return (void)))))
    (let walk ((p p))
      (match p
        [(Pattern-discard) (return (void))]
        [(Pattern-bind pp) (walk pp)]
        [(Pattern-lit a) (->preserve a)]
        [(Pattern-group (GroupType-rec label) ps) (record label (map walk (e->i ps)))]
        [(Pattern-group (GroupType-arr) ps) (map walk (e->i ps))]
        [(Pattern-group (GroupType-dict) d) (for/hash [((k pp) (in-hash d))]
                                              (values k (walk pp)))]))))