diff --git a/syndicate/pattern-test.rkt b/syndicate/pattern-test.rkt new file mode 100644 index 0000000..87e1555 --- /dev/null +++ b/syndicate/pattern-test.rkt @@ -0,0 +1,47 @@ +#lang racket/base + +(require rackunit) + +(require (for-syntax racket/base)) +(require (for-syntax "pattern.rkt")) +(require "pattern.rkt") + +(struct foo (bar zot) #:prefab) + +(define-syntax (check-analyse-pattern stx) + (syntax-case stx () + [(_ expected-pat actual-stxpat fn) + #`(check-match (fn '#,(analyse-pattern #'actual-stxpat)) expected-pat)] + [(_ expected-pat actual-stxpat) + #'(check-analyse-pattern expected-pat actual-stxpat values)])) + +(check-analyse-pattern `(compound ,_ (atom 123) (atom 234)) (foo 123 234)) +(check-analyse-pattern `(compound ,_ (discard) (atom 234)) (foo _ 234)) +(check-analyse-pattern `(compound ,_ (atom 123) (atom xyzzy)) (foo 123 xyzzy)) +(check-analyse-pattern `(compound ,_ (atom 123) (capture cap (discard))) (foo 123 $cap)) +(check-analyse-pattern `(compound ,_ (atom 123) (capture cap (atom 234))) (foo 123 ($ cap 234))) + +(check-analyse-pattern `(atom (bar 123 234)) (bar 123 234)) +(check-analyse-pattern `(atom (bar 123 $beep)) (bar 123 $beep)) + +(check-analyse-pattern `(compound list (atom 123) (capture q (discard))) (list 123 $q)) + +(define ((s->d f) desc) (syntax->datum (f desc))) + +(check-analyse-pattern '() $cap desc->key) +(check-analyse-pattern '() $cap desc->skeleton-proj) +(check-analyse-pattern '((0)) $cap desc->capture-proj) +(check-analyse-pattern '#f $cap (s->d desc->skeleton-stx)) +(check-analyse-pattern '? $cap (s->d desc->assertion-stx)) + +(check-analyse-pattern '(123) (foo 123 $cap) desc->key) +(check-analyse-pattern '((0 0)) (foo 123 $cap) desc->skeleton-proj) +(check-analyse-pattern '((0 1)) (foo 123 $cap) desc->capture-proj) +(check-analyse-pattern '(list foo? #f #f) (foo 123 $cap) (s->d desc->skeleton-stx)) +(check-analyse-pattern '(foo 123 ?) (foo 123 $cap) (s->d desc->assertion-stx)) + +(check-analyse-pattern '((bar 'beep)) (foo (bar 'beep) $cap) desc->key) +(check-analyse-pattern '((0 0)) (foo (bar 'beep) $cap) desc->skeleton-proj) +(check-analyse-pattern '((0 1)) (foo (bar 'beep) $cap) desc->capture-proj) +(check-analyse-pattern '(list foo? #f #f) (foo (bar 'beep) $cap) (s->d desc->skeleton-stx)) +(check-analyse-pattern '(foo (bar 'beep) ?) (foo (bar 'beep) $cap) (s->d desc->assertion-stx)) diff --git a/syndicate/pattern.rkt b/syndicate/pattern.rkt new file mode 100644 index 0000000..35c27cd --- /dev/null +++ b/syndicate/pattern.rkt @@ -0,0 +1,119 @@ +#lang racket/base + +(provide (all-defined-out)) + +(require racket/match) +(require racket/struct-info) +(require syntax/stx) + +(struct wildcard () #:prefab) + +(define ? (wildcard)) + +;;--------------------------------------------------------------------------- +;; ## 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 (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-transformer-identifier=? #'_ stx))) + +(define (id-value stx) + (and (identifier? stx) + (syntax-local-value stx (lambda () #f)))) + +(define (list-id? stx) + (and (identifier? stx) + (free-transformer-identifier=? #'list stx))) + +(define (analyse-pattern stx) + (syntax-case 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 ...)))] + [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 (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 ,_ ,p) (append (capture-fn key-rev) (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 '(0) desc)) + +(define (desc->key desc) + (select-pattern-leaves desc + (lambda (key-rev) (list)) + (lambda (key-rev atom) (list atom)))) + +(define (desc->skeleton-proj desc) + (select-pattern-leaves desc + (lambda (key-rev) (list)) + (lambda (key-rev atom) (list (reverse key-rev))))) + +(define (desc->capture-proj desc) + (select-pattern-leaves desc + (lambda (key-rev) (list (reverse key-rev))) + (lambda (key-rev atom) (list)))) + +(define (desc->skeleton-stx desc) + (match desc + [`(compound list ,pieces ...) + #`(list list? #,@(map desc->skeleton-stx pieces))] + [`(compound (,_struct-type ,_ctor ,pred ,_getters ,_setters ,_super) ,pieces ...) + #`(list #,pred #,@(map desc->skeleton-stx pieces))] + [`(capture ,_ ,p) (desc->skeleton-stx p)] + [`(discard) #'#f] + [`(atom ,_) #'#f])) + +(define (desc->assertion-stx desc) + (match desc + [`(compound list ,pieces ...) + #`(list #,@(map desc->assertion-stx pieces))] + [`(compound (,_struct-type ,ctor ,_pred ,_getters ,_setters ,_super) ,pieces ...) + #`(#,ctor #,@(map desc->assertion-stx pieces))] + [`(capture ,_ ,p) (desc->assertion-stx p)] + [`(discard) #'?] + [`(atom ,v) v]))