Start translation of pattern syntax to various structures

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))

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]))