;;; SPDX-License-Identifier: LGPL-3.0-or-later ;;; SPDX-FileCopyrightText: Copyright © 2015-2021 Tony Garnock-Jones #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/gen/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/gen/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))]))