syndicate-rkt/syndicate/pattern.rkt

244 lines
8.6 KiB
Racket

;;; SPDX-License-Identifier: LGPL-3.0-or-later
;;; SPDX-FileCopyrightText: Copyright © 2010-2021 Tony Garnock-Jones <tonyg@leastfixedpoint.com>
#lang racket/base
(provide (struct-out discard)
(struct-out capture)
(for-syntax analyse-pattern
instantiate-pattern->pattern
instantiate-pattern->value
desc->key
desc->skeleton-proj
desc->skeleton-stx
desc->capture-proj
desc->capture-names
desc->assertion-stx)
(all-from-out "pattern-expander.rkt"))
(require (for-syntax racket/base))
(require (for-syntax racket/match))
(require (for-syntax racket/struct-info))
(require (for-syntax syntax/stx))
(require "pattern-expander.rkt")
(struct discard () #:prefab)
(struct capture (detail) #:prefab)
;;---------------------------------------------------------------------------
;; ## Analysing patterns
;;
;; Patterns generate several pieces, which work together to form
;; routing tables:
;;
;; - the *assertion* allows observers of observers to function;
;; - the `Skeleton` classifies the shape of the pattern;
;; - two `SkProj`s select constant and variable pieces from a pattern, respectively; and
;; - a `SkKey` specifies constant pieces of a pattern, matched against one of the `SkProj`s.
;;
;; The other `SkProj` generates a second `SkKey` which is used as the
;; input to a handler function.
(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 (discard-id? stx)
(and (identifier? stx)
(free-identifier=? #'_ stx)))
(define (id-value stx)
(and (identifier? stx)
(syntax-local-value stx (lambda () #f))))
(define (list-id? stx)
(and (identifier? stx)
(free-identifier=? #'list stx)))
(define (vector-id? stx)
(and (identifier? stx)
(free-identifier=? #'vector stx)))
(define (analyse-pattern 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)
(analyse-pattern (syntax-rearm result stx))))]
;; Extremely limited support for quasiquoting and quoting
[(quasiquote (unquote p)) (analyse-pattern #'p)]
[(quasiquote (p ...)) (analyse-pattern #'(list (quasiquote p) ...))]
[(quasiquote p) (list 'atom stx)]
[(quote p) (list 'atom stx)]
[(ctor piece ...)
(struct-info? (id-value #'ctor))
(list* 'compound
(extract-struct-info (id-value #'ctor))
(stx-map analyse-pattern #'(piece ...)))]
[(list piece ...)
(list-id? #'list)
(list* 'compound
'list
(stx-map analyse-pattern #'(piece ...)))]
[(vector piece ...)
(vector-id? #'vector)
(list* 'compound
'vector
(stx-map analyse-pattern #'(piece ...)))]
[id
(dollar-id? #'id)
(list 'capture (undollar #'id) (list 'discard))]
[($ id p)
(list 'capture #'id (analyse-pattern #'p))]
[id
(discard-id? #'id)
(list 'discard)]
[_
(list 'atom stx)]))
(define (instantiate-pattern->pattern 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)
(instantiate-pattern->pattern (syntax-rearm result stx))))]
;; Extremely limited support for quasiquoting and quoting
[(quasiquote (unquote p)) (instantiate-pattern->pattern #'p)]
[(quasiquote (p ...)) (instantiate-pattern->pattern #'(list (quasiquote p) ...))]
[(quasiquote p) stx]
[(quote p) stx]
[(ctor piece ...)
(struct-info? (id-value #'ctor))
(quasisyntax/loc stx (ctor #,@(stx-map instantiate-pattern->pattern #'(piece ...))))]
[(list piece ...)
(list-id? #'list)
(quasisyntax/loc stx (list #,@(stx-map instantiate-pattern->pattern #'(piece ...))))]
[(vector piece ...)
(vector-id? #'vector)
(quasisyntax/loc stx (vector #,@(stx-map instantiate-pattern->pattern #'(piece ...))))]
[id
(dollar-id? #'id)
(undollar #'id)]
[($ id p)
#'id]
[id
(discard-id? #'id)
#'id]
[other
#'other]))
(define (instantiate-pattern->value 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)
(instantiate-pattern->value (syntax-rearm result stx))))]
;; Extremely limited support for quasiquoting and quoting
[(quasiquote (unquote p)) (instantiate-pattern->value #'p)]
[(quasiquote (p ...)) (instantiate-pattern->value #'(list (quasiquote p) ...))]
[(quasiquote p) stx]
[(quote p) stx]
[(ctor piece ...)
(struct-info? (id-value #'ctor))
(quasisyntax/loc stx (ctor #,@(stx-map instantiate-pattern->value #'(piece ...))))]
[(list piece ...)
(list-id? #'list)
(quasisyntax/loc stx (list #,@(stx-map instantiate-pattern->value #'(piece ...))))]
[(vector piece ...)
(vector-id? #'vector)
(quasisyntax/loc stx (vector #,@(stx-map instantiate-pattern->value #'(piece ...))))]
[id
(dollar-id? #'id)
(undollar #'id)]
[($ id p)
#'id]
[id
(discard-id? #'id)
#'(discard)]
[other
#'other])))
;;---------------------------------------------------------------------------
(begin-for-syntax
(define (select-pattern-leaves desc capture-fn atom-fn)
(define (walk-node key-rev desc)
(match desc
[`(compound ,_ ,pieces ...) (walk-edge 0 key-rev pieces)]
[`(capture ,name-stx ,p) (append (capture-fn key-rev name-stx) (walk-node key-rev p))]
[`(discard) (list)]
[`(atom ,v) (atom-fn key-rev v)]))
(define (walk-edge index key-rev pieces)
(match pieces
['() '()]
[(cons p pieces) (append (walk-node (cons index key-rev) p)
(walk-edge (+ index 1) key-rev pieces))]))
(walk-node '() desc))
(define (desc->key desc)
(select-pattern-leaves desc
(lambda (key-rev name-stx) (list))
(lambda (key-rev atom) (list atom))))
(define (desc->skeleton-proj desc)
(select-pattern-leaves desc
(lambda (key-rev name-stx) (list))
(lambda (key-rev atom) (list (reverse key-rev)))))
(define (desc->skeleton-stx desc)
(match desc
[`(compound list ,pieces ...)
#`(list 'list #,@(map desc->skeleton-stx pieces))]
[`(compound vector ,pieces ...)
#`(list 'vector #,@(map desc->skeleton-stx pieces))]
[`(compound (,struct-type ,_ctor ,_pred ,_getters ,_setters ,_super) ,pieces ...)
#`(list #,struct-type #,@(map desc->skeleton-stx pieces))]
[`(capture ,_ ,p) (desc->skeleton-stx p)]
[`(discard) #'#f]
[`(atom ,atom-stx) #'#f]))
(define (desc->capture-proj desc)
(select-pattern-leaves desc
(lambda (key-rev name-stx) (list (reverse key-rev)))
(lambda (key-rev atom) (list))))
(define (desc->capture-names desc)
(select-pattern-leaves desc
(lambda (key-rev name-stx) (list name-stx))
(lambda (key-rev atom) (list))))
(define (desc->assertion-stx desc)
(match desc
[`(compound list ,pieces ...)
#`(list #,@(map desc->assertion-stx pieces))]
[`(compound vector ,pieces ...)
#`(vector #,@(map desc->assertion-stx pieces))]
[`(compound (,_struct-type ,ctor ,_pred ,_getters ,_setters ,_super) ,pieces ...)
#`(#,ctor #,@(map desc->assertion-stx pieces))]
[`(capture ,_ ,p) #`(capture #,(desc->assertion-stx p))]
[`(discard) #'(discard)]
[`(atom ,v) v]))
)