70 lines
2.4 KiB
Racket
70 lines
2.4 KiB
Racket
#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)))]))))
|