2021-06-18 15:02:56 +00:00
|
|
|
#lang racket/base
|
|
|
|
;;; SPDX-License-Identifier: LGPL-3.0-or-later
|
2022-01-16 08:48:18 +00:00
|
|
|
;;; SPDX-FileCopyrightText: Copyright © 2021-2022 Tony Garnock-Jones <tonyg@leastfixedpoint.com>
|
2021-06-18 15:02:56 +00:00
|
|
|
;;; Smart constructors for compound patterns.
|
|
|
|
|
2022-01-16 23:18:57 +00:00
|
|
|
(provide rec
|
|
|
|
arr
|
|
|
|
dict
|
2021-06-18 15:02:56 +00:00
|
|
|
|
2022-01-16 23:18:57 +00:00
|
|
|
rec*
|
|
|
|
arr*
|
|
|
|
dict*
|
2021-06-18 15:02:56 +00:00
|
|
|
|
2022-01-16 23:18:57 +00:00
|
|
|
literal->literal-pattern
|
|
|
|
literal-pattern->literal
|
|
|
|
lit)
|
2021-06-18 15:02:56 +00:00
|
|
|
|
2022-01-16 23:18:57 +00:00
|
|
|
(require racket/dict)
|
|
|
|
(require racket/match)
|
2021-06-18 15:02:56 +00:00
|
|
|
|
2022-01-16 23:18:57 +00:00
|
|
|
(require preserves)
|
|
|
|
(require preserves-schema)
|
2021-06-18 15:02:56 +00:00
|
|
|
|
2022-01-16 23:18:57 +00:00
|
|
|
(require syndicate/schemas/dataspacePatterns)
|
2021-06-18 15:02:56 +00:00
|
|
|
|
2022-01-16 23:18:57 +00:00
|
|
|
(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)))]))))
|