#lang racket/base
;;; SPDX-License-Identifier: LGPL-3.0-or-later
;;; SPDX-FileCopyrightText: Copyright © 2021-2022 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 (rec label pats) (Pattern-DCompound (DCompound-rec label pats)))
(define (arr pats) (Pattern-DCompound (DCompound-arr pats)))
(define (dict pats) (Pattern-DCompound (DCompound-dict pats)))

(define (rec* label pats) (rec 'rec (list (lit label) (arr pats))))
(define (arr* pats) (rec 'arr (list (arr pats))))
(define (dict* pats) (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-DLit (DLit (parse-AnyAtom! other)))])))

(define lit literal->literal-pattern)

(define (literal-pattern->literal p)
  (let/ec return
    (let walk ((p p))
      (match p
        [(Pattern-DDiscard (DDiscard)) (return (void))]
        [(Pattern-DBind (DBind pp)) (walk pp)]
        [(Pattern-DLit (DLit a)) (->preserve a)]
        [(Pattern-DCompound (DCompound-rec label ps)) (record label (map walk ps))]
        [(Pattern-DCompound (DCompound-arr ps)) (map walk ps)]
        [(Pattern-DCompound (DCompound-dict d)) (for/hash [((k pp) (in-hash d))]
                                                  (values k (walk pp)))]))))