461 lines
18 KiB
Racket
461 lines
18 KiB
Racket
;;; SPDX-License-Identifier: LGPL-3.0-or-later
|
|
;;; SPDX-FileCopyrightText: Copyright © 2015-2021 Tony Garnock-Jones <tonyg@leastfixedpoint.com>
|
|
|
|
#lang racket/base
|
|
|
|
(provide (for-syntax preserves-pattern-registry
|
|
register-preserves-pattern!
|
|
analyse-pattern
|
|
analyse-pattern-bindings
|
|
analyse-match-pattern)
|
|
define-preserves-pattern
|
|
:pattern
|
|
:parse
|
|
|
|
pattern->constant-values
|
|
pattern->constant-paths
|
|
pattern->capture-paths
|
|
pattern->capture-names
|
|
|
|
pattern->constant
|
|
;; quote-pattern
|
|
|
|
!dump-registered-preserves-patterns!
|
|
|
|
(all-from-out "schemas/dataspacePatterns.rkt"))
|
|
|
|
(require (for-syntax racket/base))
|
|
(require (for-syntax racket/match))
|
|
(require (for-syntax racket/list))
|
|
(require (for-syntax racket/struct-info))
|
|
(require (for-syntax racket/syntax))
|
|
(require (for-syntax syntax/id-table))
|
|
(require (for-syntax syntax/stx))
|
|
|
|
(require preserves)
|
|
(require preserves-schema)
|
|
(require racket/match)
|
|
(require racket/list)
|
|
(require "pattern-expander.rkt")
|
|
(require "smart-pattern.rkt")
|
|
(require "schemas/dataspacePatterns.rkt")
|
|
|
|
;;---------------------------------------------------------------------------
|
|
|
|
(define-for-syntax preserves-pattern-registry (make-free-id-table))
|
|
|
|
(define-for-syntax (register-preserves-pattern! id-stx transformer)
|
|
(free-id-table-set! preserves-pattern-registry id-stx transformer))
|
|
|
|
(define-syntax (define-preserves-pattern stx)
|
|
(syntax-case stx ()
|
|
[(_ top-type-name parser-name (ctor-stx field-stxs ...) pattern-stx bindings-stx)
|
|
#`(begin (begin-for-syntax
|
|
(register-preserves-pattern!
|
|
#'ctor-stx
|
|
(lambda (mode s)
|
|
(match mode
|
|
['pattern
|
|
(syntax-case s ()
|
|
[(_ field-stxs ...) pattern-stx]
|
|
[_ (raise-syntax-error 'ctor-stx "Invalid pattern" s)])]
|
|
['match-pattern
|
|
(syntax-case s ()
|
|
[(_ field-stxs ...) #`(app parser-name (ctor-stx field-stxs ...))]
|
|
[_ (raise-syntax-error 'ctor-stx "Invalid match-pattern" s)])]
|
|
['bindings
|
|
(syntax-case s ()
|
|
[(_ field-stxs ...) bindings-stx]
|
|
[_ (raise-syntax-error 'ctor-stx "Invalid binding-pattern" s)])]))))
|
|
(void))]))
|
|
|
|
;;---------------------------------------------------------------------------
|
|
|
|
(define-for-syntax orig-insp
|
|
(variable-reference->module-declaration-inspector (#%variable-reference)))
|
|
|
|
(begin-for-syntax
|
|
(define (dollar-id? stx)
|
|
(and (identifier? stx)
|
|
(char=? (string-ref (symbol->string (syntax-e stx)) 0) #\$)))
|
|
|
|
(define (undollar stx)
|
|
(and (dollar-id? stx)
|
|
(datum->syntax stx (string->symbol (substring (symbol->string (syntax-e stx)) 1)))))
|
|
|
|
(define (id=? expected stx)
|
|
(and (identifier? stx)
|
|
(free-identifier=? expected stx)))
|
|
|
|
(define (id-value stx)
|
|
(and (identifier? stx)
|
|
(syntax-local-value stx (lambda () #f))))
|
|
|
|
(define (discard-id? stx) (id=? #'_ stx))
|
|
(define (list-id? stx) (id=? #'list stx))
|
|
(define (hash-or-hasheqv-id? stx) (or (id=? #'hash stx) (id=? #'hasheqv stx)))
|
|
|
|
(define (constructor-registered? stx)
|
|
(free-id-table-ref preserves-pattern-registry stx #f))
|
|
|
|
(define (struct-label-and-arity id-stx actual-count)
|
|
(match-define (list _type-stx ctor-stx pred-stx accessor-stxs _mutator-stxs _super)
|
|
(extract-struct-info (id-value id-stx)))
|
|
(define expected-count (length accessor-stxs))
|
|
(when (not (= expected-count actual-count))
|
|
(raise-syntax-error ':pattern
|
|
(format "Expected ~a arguments to ~v, but got ~a"
|
|
expected-count
|
|
ctor-stx
|
|
actual-count)))
|
|
(values (syntax-e ctor-stx)
|
|
expected-count))
|
|
|
|
(define (append-map-pairs f xs)
|
|
(match xs
|
|
['() '()]
|
|
[(list _) (raise-syntax-error #f "Odd number of elements in hash-like pattern")]
|
|
[(list* k v more) (append (f k v) (append-map-pairs f more))]))
|
|
|
|
(define (analyse-pattern stx
|
|
[check-destructuring (lambda (stx) stx)]
|
|
[wrap-literal (lambda (stx) stx)])
|
|
(define (member-entry key-stx pat-stx)
|
|
(define analysed (analyse-pattern pat-stx check-destructuring wrap-literal))
|
|
(syntax-case analysed (Pattern-DDiscard DDiscard)
|
|
[(Pattern-DDiscard (DDiscard)) (list)]
|
|
[_ (list key-stx analysed)]))
|
|
(define (walk-hash pieces-stx)
|
|
(append-map-pairs member-entry (syntax->list pieces-stx)))
|
|
(let walk ((stx stx))
|
|
(define disarmed-stx (syntax-disarm stx orig-insp))
|
|
(syntax-case disarmed-stx ($ quasiquote unquote quote)
|
|
[(expander args ...)
|
|
(pattern-expander-id? #'expander)
|
|
(pattern-expander-transform disarmed-stx
|
|
(lambda (result) (walk (syntax-rearm result stx))))]
|
|
|
|
[(ctor args ...)
|
|
(constructor-registered? #'ctor)
|
|
(check-destructuring
|
|
((free-id-table-ref preserves-pattern-registry #'ctor) 'pattern disarmed-stx))]
|
|
|
|
;; Extremely limited support for quasiquoting and quoting
|
|
[(quasiquote (unquote p)) (walk #'p)]
|
|
[(quasiquote (p ...)) (walk #'(list (quasiquote p) ...))]
|
|
[(quasiquote p) #`(Pattern-DLit (DLit #,(wrap-literal #''p)))]
|
|
[(quote p) #`(Pattern-DLit (DLit #,(wrap-literal #''p)))]
|
|
|
|
[(unquote p) #'p]
|
|
|
|
[(ctor piece ...)
|
|
(struct-info? (id-value #'ctor))
|
|
(let-values (((label arity) (struct-label-and-arity #'ctor (length (syntax->list #'(piece ...))))))
|
|
(check-destructuring
|
|
#`(make-rec-pattern '#,label #,arity
|
|
(hasheqv #,@(append*
|
|
(for/list [(n (in-naturals))
|
|
(piece (in-list (syntax->list #'(piece ...))))]
|
|
(member-entry n piece)))))))]
|
|
|
|
[(list-stx piece ...)
|
|
(list-id? #'list-stx)
|
|
(check-destructuring
|
|
#`(make-arr-pattern #,(length (syntax->list #'(piece ...)))
|
|
(hasheqv #,@(append*
|
|
(for/list [(n (in-naturals))
|
|
(piece (in-list (syntax->list #'(piece ...))))]
|
|
(member-entry n piece))))))]
|
|
|
|
[(hash-stx piece ...)
|
|
(hash-or-hasheqv-id? #'hash-stx)
|
|
(check-destructuring
|
|
#`(make-dict-pattern (hash #,@(walk-hash #'(piece ...)))))]
|
|
|
|
[id
|
|
(dollar-id? #'id)
|
|
#`(Pattern-DBind (DBind '#,(undollar #'id) (Pattern-DDiscard (DDiscard))))]
|
|
|
|
[($ (unquote bp) p)
|
|
#`(Pattern-DBind (DBind bp #,(walk #'p)))]
|
|
|
|
[($ id p)
|
|
#`(Pattern-DBind (DBind 'id #,(walk #'p)))]
|
|
|
|
[id
|
|
(discard-id? #'id)
|
|
#`(Pattern-DDiscard (DDiscard))]
|
|
|
|
[(c l a (hash-stx piece ...))
|
|
(and (id=? #'make-rec-pattern #'c)
|
|
(hash-or-hasheqv-id? #'hash-stx))
|
|
#`(make-rec-pattern* l a (hash-stx #,@(walk-hash #'(piece ...))))]
|
|
|
|
[(c a (hash-stx piece ...))
|
|
(and (id=? #'make-arr-pattern #'c)
|
|
(hash-or-hasheqv-id? #'hash-stx))
|
|
#`(make-arr-pattern* a (hash-stx #,@(walk-hash #'(piece ...))))]
|
|
|
|
[(c (hash-stx piece ...))
|
|
(and (id=? #'make-dict-pattern #'c)
|
|
(hash-or-hasheqv-id? #'hash-stx))
|
|
#`(make-dict-pattern* (hash-stx #,@(walk-hash #'(piece ...))))]
|
|
|
|
[other
|
|
#`(Pattern-DLit (DLit #,(wrap-literal #'other)))])))
|
|
|
|
(define (analyse-pattern-bindings stx)
|
|
(let walk ((stx stx))
|
|
(define disarmed-stx (syntax-disarm stx orig-insp))
|
|
(syntax-case disarmed-stx ($ quasiquote unquote quote)
|
|
[(expander args ...)
|
|
(pattern-expander-id? #'expander)
|
|
(pattern-expander-transform disarmed-stx
|
|
(lambda (result) (walk (syntax-rearm result stx))))]
|
|
|
|
[(ctor args ...)
|
|
(constructor-registered? #'ctor)
|
|
((free-id-table-ref preserves-pattern-registry #'ctor) 'bindings disarmed-stx)]
|
|
|
|
;; Extremely limited support for quasiquoting and quoting
|
|
[(quasiquote (unquote p)) (walk #'p)]
|
|
[(quasiquote (p ...)) (walk #'(list (quasiquote p) ...))]
|
|
[(quasiquote _p) '()]
|
|
[(quote _p) '()]
|
|
|
|
[(ctor piece ...)
|
|
(struct-info? (id-value #'ctor))
|
|
(append-map walk (syntax->list #'(piece ...)))]
|
|
|
|
[(list-stx piece ...)
|
|
(list-id? #'list-stx)
|
|
(append-map walk (syntax->list #'(piece ...)))]
|
|
|
|
[(hash-stx piece ...)
|
|
(hash-or-hasheqv-id? #'hash-stx)
|
|
(append-map-pairs (lambda (_k v) (walk v)) (syntax->list #'(piece ...)))]
|
|
|
|
[id
|
|
(dollar-id? #'id)
|
|
(list (undollar #'id))]
|
|
|
|
[($ id p)
|
|
(cons #'id (walk #'p))]
|
|
|
|
[id
|
|
(discard-id? #'id)
|
|
'()]
|
|
|
|
[(c l a (hash-stx piece ...))
|
|
(and (id=? #'make-rec-pattern #'c)
|
|
(hash-or-hasheqv-id? #'hash-stx))
|
|
(append-map-pairs (lambda (_k v) (walk v)) (syntax->list #'(piece ...)))]
|
|
|
|
[(c a (hash-stx piece ...))
|
|
(and (id=? #'make-arr-pattern #'c)
|
|
(hash-or-hasheqv-id? #'hash-stx))
|
|
(append-map-pairs (lambda (_k v) (walk v)) (syntax->list #'(piece ...)))]
|
|
|
|
[(c (hash-stx piece ...))
|
|
(and (id=? #'make-dict-pattern #'c)
|
|
(hash-or-hasheqv-id? #'hash-stx))
|
|
(append-map-pairs (lambda (_k v) (walk v)) (syntax->list #'(piece ...)))]
|
|
|
|
[other
|
|
'()])))
|
|
|
|
(define (analyse-match-pattern stx)
|
|
(let walk ((stx stx))
|
|
(define disarmed-stx (syntax-disarm stx orig-insp))
|
|
(syntax-case disarmed-stx ($ quasiquote unquote quote)
|
|
[(expander args ...)
|
|
(pattern-expander-id? #'expander)
|
|
(pattern-expander-transform disarmed-stx
|
|
(lambda (result) (walk (syntax-rearm result stx))))]
|
|
|
|
[(ctor args ...)
|
|
(constructor-registered? #'ctor)
|
|
((free-id-table-ref preserves-pattern-registry #'ctor) 'match-pattern disarmed-stx)]
|
|
|
|
;; Extremely limited support for quasiquoting and quoting
|
|
[(quasiquote (unquote p)) (walk #'p)]
|
|
[(quasiquote (p ...)) (walk #'(list (quasiquote p) ...))]
|
|
[(quasiquote p) #''p]
|
|
[(quote p) #''p]
|
|
|
|
[(unquote p) (raise-syntax-error #f "Out-of-place unquote in match-pattern")]
|
|
|
|
[(ctor piece ...)
|
|
(struct-info? (id-value #'ctor))
|
|
#`(ctor (:parse piece) ...)]
|
|
|
|
[(list-stx piece ...)
|
|
(list-id? #'list-stx)
|
|
#`(list-stx (:parse piece) ...)]
|
|
|
|
[(hash-stx piece ...)
|
|
(hash-or-hasheqv-id? #'hash-stx)
|
|
#`(hash-table #,@(let loop ((pieces (syntax->list #'(piece ...))))
|
|
(match pieces
|
|
['() '()]
|
|
[(list* k v more) (list* k #`(:parse #,v) (loop more))]))
|
|
[_ _] ___)]
|
|
|
|
[(or-stx piece ...)
|
|
(and (identifier? #'or-stx) (free-identifier=? #'or #'or-stx))
|
|
#`(or (:parse piece) ...)]
|
|
|
|
[(and-stx piece ...)
|
|
(and (identifier? #'and-stx) (free-identifier=? #'and #'and-stx))
|
|
#`(and (:parse piece) ...)]
|
|
|
|
[other
|
|
#`other])))
|
|
|
|
(define (expand-:pattern stx)
|
|
(syntax-case stx ()
|
|
[(_ pat-stx atomic-literal-transformer)
|
|
(analyse-pattern #'pat-stx
|
|
(lambda (stx) (raise-syntax-error #f "Attempt to destructure known-atomic"))
|
|
(lambda (stx) #`(atomic-literal-transformer #,stx)))]
|
|
[(_ pat-stx)
|
|
(analyse-pattern #'pat-stx)])))
|
|
|
|
(define-pattern-expander :pattern
|
|
(lambda (stx)
|
|
;; This effectively quasiquotes the pattern; a naked unquote in
|
|
;; the pattern returns to the "outer" context. This is useful for
|
|
;; observing observers:
|
|
;;
|
|
;; (Observe (:pattern (some-pattern ...)) _)
|
|
;;
|
|
(expand-:pattern stx))
|
|
(lambda (stx)
|
|
(expand-:pattern stx)))
|
|
|
|
(define-match-expander :parse
|
|
(lambda (stx)
|
|
(syntax-case stx ()
|
|
[(_ pat-stx) (analyse-match-pattern #'pat-stx)])))
|
|
|
|
;;---------------------------------------------------------------------------
|
|
|
|
(define (select-pattern-leaves desc capture-fn lit-fn)
|
|
(let walk-node ((key-rev '()) (desc desc))
|
|
(match desc
|
|
[(Pattern-DCompound (or (DCompound-rec _ members)
|
|
(DCompound-arr _ members)
|
|
(DCompound-dict _ members)))
|
|
(append* (for/list [((key subdesc) (in-hash members))]
|
|
(walk-node (cons key key-rev) subdesc)))]
|
|
[(Pattern-DBind (DBind name subdesc))
|
|
(append (capture-fn key-rev name) (walk-node key-rev subdesc))]
|
|
[(Pattern-DDiscard (DDiscard))
|
|
'()]
|
|
[(Pattern-DLit (DLit value))
|
|
(lit-fn key-rev value)])))
|
|
|
|
(define (pattern->constant-values desc)
|
|
(select-pattern-leaves desc
|
|
(lambda (key-rev name-stx) (list))
|
|
(lambda (key-rev value) (list value))))
|
|
|
|
(define (pattern->constant-paths desc)
|
|
(select-pattern-leaves desc
|
|
(lambda (key-rev name-stx) (list))
|
|
(lambda (key-rev value) (list (reverse key-rev)))))
|
|
|
|
(define (pattern->capture-paths desc)
|
|
(select-pattern-leaves desc
|
|
(lambda (key-rev name-stx) (list (reverse key-rev)))
|
|
(lambda (key-rev value) (list))))
|
|
|
|
(define (pattern->capture-names desc)
|
|
(select-pattern-leaves desc
|
|
(lambda (key-rev name-stx) (list name-stx))
|
|
(lambda (key-rev value) (list))))
|
|
|
|
(define (pattern->constant desc [env (lambda (name index) (void))])
|
|
(define next-binding-index 0)
|
|
(define (walk p k)
|
|
(match p
|
|
[(Pattern-DDiscard (DDiscard)) (void)]
|
|
[(Pattern-DBind (DBind name pat))
|
|
(let ((v (env name next-binding-index)))
|
|
(set! next-binding-index (+ next-binding-index 1))
|
|
(let ((inner (walk pat values)))
|
|
(k (if (void? v) inner v))))]
|
|
[(Pattern-DLit (DLit value)) (k value)]
|
|
[(Pattern-DCompound (DCompound-rec (CRec label arity) members))
|
|
(let loop ((fields-rev '()) (i 0))
|
|
(if (= i arity)
|
|
(k (record label (reverse fields-rev)))
|
|
(let ((vpat (hash-ref members i #f)))
|
|
(if vpat
|
|
(walk vpat (lambda (v) (loop (cons v fields-rev) (+ i 1))))
|
|
(void)))))]
|
|
[(Pattern-DCompound (DCompound-arr (CArr arity) members))
|
|
(let loop ((items-rev '()) (i 0))
|
|
(if (= i arity)
|
|
(k (reverse items-rev))
|
|
(let ((vpat (hash-ref members i #f)))
|
|
(if vpat
|
|
(walk vpat (lambda (v) (loop (cons v items-rev) (+ i 1))))
|
|
(void)))))]
|
|
[(Pattern-DCompound (DCompound-dict (CDict) members))
|
|
(let loop ((items (hash)) (entries (hash->list members)))
|
|
(match entries
|
|
['() (k items)]
|
|
[(cons (cons key vpat) more)
|
|
(walk vpat (lambda (v) (loop (hash-set items key v) more)))]))]))
|
|
(walk (parse-Pattern desc) values))
|
|
|
|
;; (define (quote-pattern p)
|
|
;; (match p
|
|
;; [(Pattern-DDiscard (DDiscard))
|
|
;; (Pattern-DCompound (DCompound-rec (CRec '_ 0) (hash)))]
|
|
;; [(Pattern-DBind (DBind name pat))
|
|
;; (Pattern-DCompound (DCompound-rec (CRec 'bind 2)
|
|
;; (hash 0 (Pattern-DLit (DLit name)) 1 (quote-pattern pat))))]
|
|
;; [(Pattern-DLit value)
|
|
;; (Pattern-DCompound (DCompound-rec (CRec 'lit 1) (hash 0 (Pattern-DLit (DLit value)))))]
|
|
;; [(Pattern-DCompound (DCompound-rec (CRec label arity) members))
|
|
;; (Pattern-DCompound
|
|
;; (DCompound-rec (CRec 'compound 2)
|
|
;; (hash 0 (Pattern-DCompound
|
|
;; (DCompound-rec (CRec 'rec 2)
|
|
;; (hash 0 (Pattern-DLit (DLit label))
|
|
;; 1 (Pattern-DLit (DLit arity)))))
|
|
;; 1 (Pattern-DCompound
|
|
;; (DCompound-dict (CDict)
|
|
;; (for/hash ([(kv vp) (in-hash members)])
|
|
;; (values kv (quote-pattern vp))))))))]
|
|
;; [(Pattern-DCompound (DCompound-arr (CArr arity) members))
|
|
;; (Pattern-DCompound
|
|
;; (DCompound-rec (CRec 'compound 2)
|
|
;; (hash 0 (Pattern-DCompound
|
|
;; (DCompound-rec (CRec 'arr 1)
|
|
;; (hash 0 (Pattern-DLit (DLit arity)))))
|
|
;; 1 (Pattern-DCompound
|
|
;; (DCompound-dict (CDict)
|
|
;; (for/hash ([(kv vp) (in-hash members)])
|
|
;; (values kv (quote-pattern vp))))))))]
|
|
;; [(Pattern-DCompound (DCompound-dict (CDict) members))
|
|
;; (Pattern-DCompound
|
|
;; (DCompound-rec (CRec 'compound 2)
|
|
;; (hash 0 (Pattern-DCompound
|
|
;; (DCompound-rec (CRec 'dict 0) (hash)))
|
|
;; 1 (Pattern-DCompound
|
|
;; (DCompound-dict (CDict)
|
|
;; (for/hash ([(kv vp) (in-hash members)])
|
|
;; (values kv (quote-pattern vp))))))))]))
|
|
|
|
(define-syntax (!dump-registered-preserves-patterns! stx)
|
|
(syntax-case stx ()
|
|
[(_)
|
|
(let ()
|
|
(local-require racket/pretty)
|
|
(for [(k (in-list (free-id-table-keys preserves-pattern-registry)))]
|
|
(printf " - ~v\n" k))
|
|
#'(void))]))
|