100 lines
2.9 KiB
Racket
100 lines
2.9 KiB
Racket
#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 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/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)))
|