syndicate-rkt/syndicate/smart-pattern.rkt

55 lines
1.8 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 (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)))]))))