2018-03-21 08:16:54 +00:00
|
|
|
#lang racket/base
|
|
|
|
|
2018-03-21 20:01:07 +00:00
|
|
|
(provide analyse-pattern
|
|
|
|
desc->key
|
|
|
|
desc->skeleton-proj
|
|
|
|
desc->capture-proj
|
|
|
|
desc->skeleton-stx
|
|
|
|
desc->assertion-stx)
|
2018-03-21 08:16:54 +00:00
|
|
|
|
|
|
|
(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]))
|