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

(provide make-rec-pattern
         make-arr-pattern
         make-dict-pattern

         make-rec-pattern*
         make-arr-pattern*
         make-dict-pattern*)

(require racket/match)
(require preserves)
(require syndicate/schemas/gen/dataspacePatterns)

(define (rec label arity pats)
  (Pattern-DCompound (DCompound-rec (CRec label arity) pats)))

(define (arr arity pats)
  (Pattern-DCompound (DCompound-arr (CArr arity) pats)))

(define (dict pats)
  (Pattern-DCompound (DCompound-dict (CDict) pats)))

(define (unlit? p)
  (match p
    [(Pattern-DLit (DLit _)) #t]
    [(DLit _) #t]
    [_ #f]))

(define (unlit p)
  (match p
    [(Pattern-DLit (DLit v)) v]
    [(DLit v) v]))

(define (lit v)
  (Pattern-DLit (DLit v)))

(define (make-rec-pattern label arity pats)
  (if (and (= arity (hash-count pats))
           (andmap unlit? (hash-values pats)))
      (lit (record label (for/list [(i (in-range arity))] (unlit (hash-ref pats i)))))
      (rec label arity pats)))

(define (make-arr-pattern arity pats)
  (if (and (= arity (hash-count pats))
           (andmap unlit? (hash-values pats)))
      (lit (for/list [(i (in-range arity))] (unlit (hash-ref pats i))))
      (arr arity pats)))

(define (make-dict-pattern pats)
  (if (andmap unlit? (hash-values pats))
      (lit (for/hash [((k v) (in-hash pats))] (values k (unlit v))))
      (dict pats)))

(define (rec* label arity pats)
  (Pattern-DCompound
   (DCompound-rec (CRec 'compound 2)
                  (hash 0 (lit (CRec label arity))
                        1 (dict pats)))))

(define (arr* arity pats)
  (Pattern-DCompound
   (DCompound-rec (CRec 'compound 2)
                  (hash 0 (lit (CArr arity))
                        1 (dict pats)))))

(define (dict* pats)
  (Pattern-DCompound
   (DCompound-rec (CRec 'compound 2)
                  (hash 0 (lit (CDict))
                        1 (dict pats)))))

(define (unlit* p)
  (match p
    [(Pattern-DCompound (DCompound-rec (CRec 'lit 1) (hash-table [0 v]))) v]
    [_ #f]))

(define (lit* v)
  (rec 'lit 1 (hasheqv 0 v)))

(define (make-rec-pattern* label arity pats)
  (if (and (= arity (hash-count pats))
           (andmap unlit* (hash-values pats)))
      (lit* (rec label arity (for/hash [((k v) (in-hash pats))] (values k (unlit* v)))))
      (rec* label arity pats)))

(define (make-arr-pattern* arity pats)
  (if (and (= arity (hash-count pats))
           (andmap unlit* (hash-values pats)))
      (lit* (arr arity (for/hash [((k v) (in-hash pats))] (values k (unlit* v)))))
      (arr* arity pats)))

(define (make-dict-pattern* pats)
  (if (andmap unlit* (hash-values pats))
      (lit* (dict (for/hash [((k v) (in-hash pats))] (values k (unlit* v)))))
      (dict* pats)))