Work towards schema-to-pattern compiler
This commit is contained in:
parent
5c97661c73
commit
ac01ce4dfe
|
@ -0,0 +1,240 @@
|
||||||
|
#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]))
|
||||||
|
)
|
|
@ -1,42 +1,48 @@
|
||||||
#lang racket/base
|
#lang racket/base
|
||||||
|
|
||||||
(provide (struct-out discard)
|
(provide (for-syntax preserves-pattern-registry
|
||||||
(struct-out capture)
|
register-preserves-pattern!
|
||||||
|
analyse-pattern
|
||||||
(for-syntax analyse-pattern
|
analyse-pattern-bindings)
|
||||||
instantiate-pattern->pattern
|
define-preserves-pattern
|
||||||
instantiate-pattern->value
|
:pattern)
|
||||||
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/base))
|
||||||
(require (for-syntax racket/match))
|
(require (for-syntax racket/match))
|
||||||
|
(require (for-syntax racket/list))
|
||||||
(require (for-syntax racket/struct-info))
|
(require (for-syntax racket/struct-info))
|
||||||
|
(require (for-syntax syntax/id-table))
|
||||||
(require (for-syntax syntax/stx))
|
(require (for-syntax syntax/stx))
|
||||||
(require "pattern-expander.rkt")
|
|
||||||
|
|
||||||
(struct discard () #:prefab)
|
(require "pattern-expander.rkt")
|
||||||
(struct capture (detail) #:prefab)
|
(require "schemas/gen/dataspace-patterns.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 ()
|
||||||
|
[(_ (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")])]
|
||||||
|
['bindings
|
||||||
|
(syntax-case s ()
|
||||||
|
[(_ field-stxs ...) bindings-stx]
|
||||||
|
[_ (raise-syntax-error 'ctor-stx "Invalid binding-pattern")])]))))
|
||||||
|
(void))]))
|
||||||
|
|
||||||
;;---------------------------------------------------------------------------
|
;;---------------------------------------------------------------------------
|
||||||
;; ## 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
|
(define-for-syntax orig-insp
|
||||||
(variable-reference->module-declaration-inspector (#%variable-reference)))
|
(variable-reference->module-declaration-inspector (#%variable-reference)))
|
||||||
|
@ -62,13 +68,35 @@
|
||||||
(and (identifier? stx)
|
(and (identifier? stx)
|
||||||
(free-identifier=? #'list stx)))
|
(free-identifier=? #'list stx)))
|
||||||
|
|
||||||
(define (vector-id? stx)
|
(define (constructor-registered? stx)
|
||||||
(and (identifier? stx)
|
(free-id-table-ref preserves-pattern-registry stx #f))
|
||||||
(free-identifier=? #'vector stx)))
|
|
||||||
|
(define (member-entry key-stx pat-stx)
|
||||||
|
(define analysed (analyse-pattern pat-stx))
|
||||||
|
(syntax-case analysed (DDiscard)
|
||||||
|
[(DDiscard) (list)]
|
||||||
|
[_ (list key-stx analysed)]))
|
||||||
|
|
||||||
|
(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 (analyse-pattern stx)
|
(define (analyse-pattern stx)
|
||||||
(define disarmed-stx (syntax-disarm stx orig-insp))
|
(define disarmed-stx (syntax-disarm stx orig-insp))
|
||||||
(syntax-case disarmed-stx ($ quasiquote unquote quote)
|
(syntax-case disarmed-stx ($ quasiquote unquote quote)
|
||||||
|
[(ctor args ...)
|
||||||
|
(constructor-registered? #'ctor)
|
||||||
|
((free-id-table-ref preserves-pattern-registry #'ctor) 'pattern disarmed-stx)]
|
||||||
|
|
||||||
[(expander args ...)
|
[(expander args ...)
|
||||||
(pattern-expander-id? #'expander)
|
(pattern-expander-id? #'expander)
|
||||||
(pattern-expander-transform disarmed-stx
|
(pattern-expander-transform disarmed-stx
|
||||||
|
@ -78,163 +106,89 @@
|
||||||
;; Extremely limited support for quasiquoting and quoting
|
;; Extremely limited support for quasiquoting and quoting
|
||||||
[(quasiquote (unquote p)) (analyse-pattern #'p)]
|
[(quasiquote (unquote p)) (analyse-pattern #'p)]
|
||||||
[(quasiquote (p ...)) (analyse-pattern #'(list (quasiquote p) ...))]
|
[(quasiquote (p ...)) (analyse-pattern #'(list (quasiquote p) ...))]
|
||||||
[(quasiquote p) (list 'atom stx)]
|
[(quasiquote p) #`(DLit 'p)]
|
||||||
[(quote p) (list 'atom stx)]
|
[(quote p) #`(DLit 'p)]
|
||||||
|
|
||||||
[(ctor piece ...)
|
[(ctor piece ...)
|
||||||
(struct-info? (id-value #'ctor))
|
(struct-info? (id-value #'ctor))
|
||||||
(list* 'compound
|
(let-values (((label arity) (struct-label-and-arity #'ctor)))
|
||||||
(extract-struct-info (id-value #'ctor))
|
#`(DCompound-rec '#,label
|
||||||
(stx-map analyse-pattern #'(piece ...)))]
|
#,arity
|
||||||
[(list piece ...)
|
(hasheqv #,@(append*
|
||||||
(list-id? #'list)
|
(for/list [(n (in-naturals))
|
||||||
(list* 'compound
|
(piece (in-list (syntax->list #'(piece ...))))]
|
||||||
'list
|
(member-entry n piece))))))]
|
||||||
(stx-map analyse-pattern #'(piece ...)))]
|
|
||||||
[(vector piece ...)
|
[(list-stx piece ...)
|
||||||
(vector-id? #'vector)
|
(list-id? #'list-stx)
|
||||||
(list* 'compound
|
#`(DCompound-arr #,(length (syntax->list #'(piece ...)))
|
||||||
'vector
|
(hasheqv #,@(append*
|
||||||
(stx-map analyse-pattern #'(piece ...)))]
|
(for/list [(n (in-naturals))
|
||||||
|
(piece (in-list (syntax->list #'(piece ...))))]
|
||||||
|
(member-entry n piece)))))]
|
||||||
|
|
||||||
[id
|
[id
|
||||||
(dollar-id? #'id)
|
(dollar-id? #'id)
|
||||||
(list 'capture (undollar #'id) (list 'discard))]
|
#`(DBind '#,(undollar #'id) (DDiscard))]
|
||||||
|
|
||||||
[($ id p)
|
[($ id p)
|
||||||
(list 'capture #'id (analyse-pattern #'p))]
|
#`(DBind 'id #,(analyse-pattern #'p))]
|
||||||
|
|
||||||
[id
|
[id
|
||||||
(discard-id? #'id)
|
(discard-id? #'id)
|
||||||
(list 'discard)]
|
#`(DDiscard)]
|
||||||
[_
|
|
||||||
(list 'atom stx)]))
|
|
||||||
|
|
||||||
(define (instantiate-pattern->pattern stx)
|
[other
|
||||||
|
#`(DLit other)]))
|
||||||
|
|
||||||
|
(define (analyse-pattern-bindings stx)
|
||||||
(define disarmed-stx (syntax-disarm stx orig-insp))
|
(define disarmed-stx (syntax-disarm stx orig-insp))
|
||||||
(syntax-case disarmed-stx ($ quasiquote unquote quote)
|
(syntax-case disarmed-stx ($ quasiquote unquote quote)
|
||||||
|
[(ctor args ...)
|
||||||
|
(constructor-registered? #'ctor)
|
||||||
|
((free-id-table-ref preserves-pattern-registry #'ctor) 'bindings disarmed-stx)]
|
||||||
|
|
||||||
[(expander args ...)
|
[(expander args ...)
|
||||||
(pattern-expander-id? #'expander)
|
(pattern-expander-id? #'expander)
|
||||||
(pattern-expander-transform disarmed-stx
|
(pattern-expander-transform disarmed-stx
|
||||||
(lambda (result)
|
(lambda (result)
|
||||||
(instantiate-pattern->pattern (syntax-rearm result stx))))]
|
(analyse-pattern-bindings (syntax-rearm result stx))))]
|
||||||
|
|
||||||
;; Extremely limited support for quasiquoting and quoting
|
;; Extremely limited support for quasiquoting and quoting
|
||||||
[(quasiquote (unquote p)) (instantiate-pattern->pattern #'p)]
|
[(quasiquote (unquote p)) (analyse-pattern-bindings #'p)]
|
||||||
[(quasiquote (p ...)) (instantiate-pattern->pattern #'(list (quasiquote p) ...))]
|
[(quasiquote (p ...)) (analyse-pattern-bindings #'(list (quasiquote p) ...))]
|
||||||
[(quasiquote p) stx]
|
[(quasiquote _p) '()]
|
||||||
[(quote p) stx]
|
[(quote _p) '()]
|
||||||
|
|
||||||
[(ctor piece ...)
|
[(ctor piece ...)
|
||||||
(struct-info? (id-value #'ctor))
|
(struct-info? (id-value #'ctor))
|
||||||
(quasisyntax/loc stx (ctor #,@(stx-map instantiate-pattern->pattern #'(piece ...))))]
|
(append-map analyse-pattern-bindings (syntax->list #'(piece ...)))]
|
||||||
[(list piece ...)
|
|
||||||
(list-id? #'list)
|
[(list-stx piece ...)
|
||||||
(quasisyntax/loc stx (list #,@(stx-map instantiate-pattern->pattern #'(piece ...))))]
|
(list-id? #'list-stx)
|
||||||
[(vector piece ...)
|
(append-map analyse-pattern-bindings (syntax->list #'(piece ...)))]
|
||||||
(vector-id? #'vector)
|
|
||||||
(quasisyntax/loc stx (vector #,@(stx-map instantiate-pattern->pattern #'(piece ...))))]
|
|
||||||
[id
|
[id
|
||||||
(dollar-id? #'id)
|
(dollar-id? #'id)
|
||||||
(undollar #'id)]
|
(list (undollar #'id))]
|
||||||
|
|
||||||
[($ id p)
|
[($ id p)
|
||||||
#'id]
|
(cons #'id (analyse-pattern-bindings #'p))]
|
||||||
|
|
||||||
[id
|
[id
|
||||||
(discard-id? #'id)
|
(discard-id? #'id)
|
||||||
#'id]
|
'()]
|
||||||
|
|
||||||
[other
|
[other
|
||||||
#'other]))
|
'()])))
|
||||||
|
|
||||||
(define (instantiate-pattern->value stx)
|
(define-syntax (:pattern stx)
|
||||||
(define disarmed-stx (syntax-disarm stx orig-insp))
|
(syntax-case stx ()
|
||||||
(syntax-case disarmed-stx ($ quasiquote unquote quote)
|
[(_ pat-stx)
|
||||||
[(expander args ...)
|
(analyse-pattern #'pat-stx)]))
|
||||||
(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
|
(provide :bindings)
|
||||||
[(quasiquote (unquote p)) (instantiate-pattern->value #'p)]
|
(define-syntax (:bindings stx)
|
||||||
[(quasiquote (p ...)) (instantiate-pattern->value #'(list (quasiquote p) ...))]
|
(syntax-case stx ()
|
||||||
[(quasiquote p) stx]
|
[(_ pat-stx)
|
||||||
[(quote p) stx]
|
#`(quote #,(analyse-pattern-bindings #'pat-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]))
|
|
||||||
)
|
|
||||||
|
|
|
@ -2,14 +2,104 @@
|
||||||
|
|
||||||
(provide schema-compiler-plugin)
|
(provide schema-compiler-plugin)
|
||||||
|
|
||||||
|
(require racket/pretty)
|
||||||
(require racket/match)
|
(require racket/match)
|
||||||
|
(require (only-in racket/file make-parent-directory*))
|
||||||
|
(require (only-in racket/syntax format-symbol))
|
||||||
|
(require (only-in racket/list append* append-map))
|
||||||
|
|
||||||
(require preserves-schema/compiler)
|
(require preserves-schema/compiler)
|
||||||
|
(require preserves-schema/type)
|
||||||
|
(require preserves-schema/gen/schema)
|
||||||
|
|
||||||
(define (schema-compiler-plugin schema options)
|
(define (schema-compiler-plugin schema options)
|
||||||
(match-define (schema-compiler-options _name
|
(match-define (schema-compiler-options _name
|
||||||
lookup-module-path
|
lookup-module-path
|
||||||
paths) options)
|
paths) options)
|
||||||
(define ds-path (lookup-module-path '(dataspace-patterns)))
|
(define ds-path (lookup-module-path '(dataspace-patterns)))
|
||||||
(if (equal? ds-path (schema-translation-paths-relative-output-path paths))
|
(define meta? (equal? ds-path (schema-translation-paths-relative-output-path paths)))
|
||||||
`(begin)
|
|
||||||
`(begin (require (prefix-in :pat: ,ds-path)))))
|
(define (N sym)
|
||||||
|
(if meta?
|
||||||
|
sym
|
||||||
|
(format-symbol ":pat:~a" sym)))
|
||||||
|
|
||||||
|
(define (def-pattern name def)
|
||||||
|
(define discard `(,(N 'DDiscard)))
|
||||||
|
|
||||||
|
(define (pat-pattern p)
|
||||||
|
(match (unwrap p)
|
||||||
|
[(NamedSimplePattern_ name p)
|
||||||
|
`(:pattern ,(escape name))]
|
||||||
|
[(SimplePattern-any) discard]
|
||||||
|
[(SimplePattern-atom _atomKind) discard]
|
||||||
|
[(SimplePattern-embedded _interface) discard]
|
||||||
|
[(SimplePattern-lit value) `(,(N 'DLit) ',value)]
|
||||||
|
[(SimplePattern-seqof pat) discard]
|
||||||
|
[(SimplePattern-setof pat) discard]
|
||||||
|
[(SimplePattern-dictof key-pat value-pat) discard]
|
||||||
|
[(SimplePattern-Ref (Ref module-path name))
|
||||||
|
`(:pattern-ref ,(format-symbol "~a~a" (module-path-prefix module-path) name))]
|
||||||
|
[(CompoundPattern-rec label-pat fields-pat)
|
||||||
|
(match* ((unwrap label-pat) (unwrap fields-pat))
|
||||||
|
[((SimplePattern-lit label) (CompoundPattern-tuple field-pats))
|
||||||
|
`(,(N 'DCompound-rec)
|
||||||
|
',label
|
||||||
|
,(length field-pats)
|
||||||
|
(hasheqv ,@(append* (for/list [(i (in-naturals))
|
||||||
|
(p (in-list field-pats))]
|
||||||
|
(define s (pat-pattern p))
|
||||||
|
(if (equal? s discard)
|
||||||
|
`()
|
||||||
|
`(,i ,s))))))]
|
||||||
|
[(_ _) `#,(raise-syntax-error ',name "Record schema cannot be used as a pattern")])]
|
||||||
|
[(CompoundPattern-tuple pats)
|
||||||
|
`(,(N 'DCompound-arr)
|
||||||
|
,(length pats)
|
||||||
|
(hasheqv ,@(append* (for/list [(i (in-naturals))
|
||||||
|
(p (in-list pats))]
|
||||||
|
(define s (pat-pattern p))
|
||||||
|
(if (equal? s discard)
|
||||||
|
`()
|
||||||
|
`(,i ,p))))))]
|
||||||
|
[other (error 'pat-pattern "Unimplemented: ~v" other)]))
|
||||||
|
|
||||||
|
(define fields (match (definition-ty def)
|
||||||
|
[(ty-unit) '()]
|
||||||
|
[(ty-record fields) (map escape (map car fields))]
|
||||||
|
[_ #f]))
|
||||||
|
|
||||||
|
(if (not fields)
|
||||||
|
`(begin)
|
||||||
|
`(define-preserves-pattern (,name ,@fields)
|
||||||
|
,@(match def
|
||||||
|
[(? Definition-or?)
|
||||||
|
`((raise-syntax-error ',name "Union schema cannot be used as a pattern")
|
||||||
|
(quasisyntax ()))]
|
||||||
|
[(? Definition-and?)
|
||||||
|
`((raise-syntax-error ',name "Intersection schema cannot be used as a pattern")
|
||||||
|
(quasisyntax ()))]
|
||||||
|
[(Definition-Pattern p)
|
||||||
|
`((quasisyntax ,(pat-pattern p))
|
||||||
|
(append ,@(for/list [(f (in-list fields))]
|
||||||
|
`(analyse-pattern-bindings (syntax ,f)))))]))))
|
||||||
|
|
||||||
|
(define exprs
|
||||||
|
`((require (prefix-in :pat: ,ds-path))
|
||||||
|
(require syndicate/pattern)
|
||||||
|
(require (for-syntax racket/base))
|
||||||
|
,@(map-Schema-definitions def-pattern schema)))
|
||||||
|
|
||||||
|
(if meta?
|
||||||
|
(let ((output-path (path-replace-extension
|
||||||
|
(schema-translation-paths-full-output-path paths)
|
||||||
|
".meta.rkt")))
|
||||||
|
(make-parent-directory* output-path)
|
||||||
|
(with-output-to-file output-path #:exists 'replace
|
||||||
|
(lambda ()
|
||||||
|
(displayln "#lang racket/base\n")
|
||||||
|
(for [(e (in-list exprs))]
|
||||||
|
(pretty-write e)
|
||||||
|
(newline))))
|
||||||
|
`(begin))
|
||||||
|
`(begin ,@exprs)))
|
||||||
|
|
Loading…
Reference in New Issue