syndicate-lang
/
syndicate-rkt
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

Correct generation of patterns for literal embedded-values

This commit is contained in:
Tony Garnock-Jones 2021-06-10 13:32:39 +02:00
parent 7790923e65
commit 3984a2c22a
2 changed files with 83 additions and 69 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

150
syndicate/pattern.rkt
View File

@ -92,12 +92,6 @@
(define (constructor-registered? stx) (define (constructor-registered? stx)
(free-id-table-ref preserves-pattern-registry stx #f)) (free-id-table-ref preserves-pattern-registry stx #f))
(define (member-entry key-stx pat-stx)
(define analysed (analyse-pattern pat-stx))
(syntax-case analysed (Pattern-DDiscard DDiscard)
[(Pattern-DDiscard (DDiscard)) (list)]
[_ (list key-stx analysed)]))
(define (struct-label-and-arity id-stx actual-count) (define (struct-label-and-arity id-stx actual-count)
(match-define (list _type-stx ctor-stx pred-stx accessor-stxs _mutator-stxs _super) (match-define (list _type-stx ctor-stx pred-stx accessor-stxs _mutator-stxs _super)
(extract-struct-info (id-value id-stx))) (extract-struct-info (id-value id-stx)))
@ -117,68 +111,80 @@
[(list _) (raise-syntax-error #f "Odd number of elements in hash-like pattern")] [(list _) (raise-syntax-error #f "Odd number of elements in hash-like pattern")]
[(list* k v more) (append (f k v) (append-map-pairs f more))])) [(list* k v more) (append (f k v) (append-map-pairs f more))]))
(define (analyse-pattern stx) (define (analyse-pattern stx
(define disarmed-stx (syntax-disarm stx orig-insp)) [check-destructuring (lambda (stx) stx)]
(syntax-case disarmed-stx ($ quasiquote unquote quote) [wrap-literal (lambda (stx) stx)])
[(ctor args ...) (define (member-entry key-stx pat-stx)
(constructor-registered? #'ctor) (define analysed (analyse-pattern pat-stx check-destructuring wrap-literal))
((free-id-table-ref preserves-pattern-registry #'ctor) 'pattern disarmed-stx)] (syntax-case analysed (Pattern-DDiscard DDiscard)
[(Pattern-DDiscard (DDiscard)) (list)]
[_ (list key-stx analysed)]))
(let walk ((stx stx))
(define disarmed-stx (syntax-disarm stx orig-insp))
(syntax-case disarmed-stx ($ quasiquote unquote quote)
[(ctor args ...)
(constructor-registered? #'ctor)
(check-destructuring
((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
(lambda (result) (lambda (result)
(analyse-pattern (syntax-rearm result stx))))] (walk (syntax-rearm result stx))))]
;; Extremely limited support for quasiquoting and quoting ;; Extremely limited support for quasiquoting and quoting
[(quasiquote (unquote p)) (analyse-pattern #'p)] [(quasiquote (unquote p)) (walk #'p)]
[(quasiquote (p ...)) (analyse-pattern #'(list (quasiquote p) ...))] [(quasiquote (p ...)) (walk #'(list (quasiquote p) ...))]
[(quasiquote p) #`(Pattern-DLit (DLit 'p))] [(quasiquote p) #`(Pattern-DLit (DLit #,(wrap-literal #''p)))]
[(quote p) #`(Pattern-DLit (DLit 'p))] [(quote p) #`(Pattern-DLit (DLit #,(wrap-literal #''p)))]
[(unquote p) #'p] [(unquote p) #'p]
[(ctor piece ...) [(ctor piece ...)
(struct-info? (id-value #'ctor)) (struct-info? (id-value #'ctor))
(let-values (((label arity) (struct-label-and-arity #'ctor (length (syntax->list #'(piece ...)))))) (let-values (((label arity) (struct-label-and-arity #'ctor (length (syntax->list #'(piece ...))))))
#`(Pattern-DCompound (check-destructuring
(DCompound-rec (CRec '#,label #,arity) #`(Pattern-DCompound
(hasheqv #,@(append* (DCompound-rec (CRec '#,label #,arity)
(for/list [(n (in-naturals)) (hasheqv #,@(append*
(piece (in-list (syntax->list #'(piece ...))))] (for/list [(n (in-naturals))
(member-entry n piece)))))))] (piece (in-list (syntax->list #'(piece ...))))]
(member-entry n piece))))))))]
[(list-stx piece ...) [(list-stx piece ...)
(list-id? #'list-stx) (list-id? #'list-stx)
#`(Pattern-DCompound (check-destructuring
(DCompound-arr (CArr #,(length (syntax->list #'(piece ...)))) #`(Pattern-DCompound
(hasheqv #,@(append* (DCompound-arr (CArr #,(length (syntax->list #'(piece ...))))
(for/list [(n (in-naturals)) (hasheqv #,@(append*
(piece (in-list (syntax->list #'(piece ...))))] (for/list [(n (in-naturals))
(member-entry n piece))))))] (piece (in-list (syntax->list #'(piece ...))))]
(member-entry n piece)))))))]
[(hash-stx piece ...) [(hash-stx piece ...)
(hash-or-hasheqv-id? #'hash-stx) (hash-or-hasheqv-id? #'hash-stx)
#`(Pattern-DCompound (check-destructuring
(DCompound-dict (CDict) #`(Pattern-DCompound
(hash #,@(append-map-pairs member-entry (syntax->list #'(piece ...))))))] (DCompound-dict (CDict)
(hash #,@(append-map-pairs member-entry (syntax->list #'(piece ...)))))))]
[id [id
(dollar-id? #'id) (dollar-id? #'id)
#`(Pattern-DBind (DBind '#,(undollar #'id) (Pattern-DDiscard (DDiscard))))] #`(Pattern-DBind (DBind '#,(undollar #'id) (Pattern-DDiscard (DDiscard))))]
[($ (unquote bp) p) [($ (unquote bp) p)
#`(Pattern-DBind (DBind bp #,(analyse-pattern #'p)))] #`(Pattern-DBind (DBind bp #,(walk #'p)))]
[($ id p) [($ id p)
#`(Pattern-DBind (DBind 'id #,(analyse-pattern #'p)))] #`(Pattern-DBind (DBind 'id #,(walk #'p)))]
[id [id
(discard-id? #'id) (discard-id? #'id)
#`(Pattern-DDiscard (DDiscard))] #`(Pattern-DDiscard (DDiscard))]
[other [other
#`(Pattern-DLit (DLit other))])) #`(Pattern-DLit (DLit #,(wrap-literal #'other)))])))
(define (analyse-pattern-bindings stx) (define (analyse-pattern-bindings stx)
(let walk ((stx stx)) (let walk ((stx stx))
@ -223,22 +229,28 @@
'()] '()]
[other [other
'()])))) '()])))
(define (expand-:pattern stx)
(syntax-case stx ()
[(_ pat-stx atomic-literal-transformer)
(analyse-pattern #'pat-stx
(lambda (stx) (raise-syntax-error #f "Attempt to destructure known-atomic"))
(lambda (stx) #`(atomic-literal-transformer #,stx)))]
[(_ pat-stx)
(analyse-pattern #'pat-stx)])))
(define-pattern-expander :pattern (define-pattern-expander :pattern
(lambda (stx) (lambda (stx)
(syntax-case stx () ;; This effectively quasiquotes the pattern; a naked unquote in
[(_ pat-stx) ;; the pattern returns to the "outer" context. This is useful for
;; This effectively quasiquotes the pattern; a naked unquote in ;; observing observers:
;; the pattern returns to the "outer" context. This is useful ;;
;; for observing observers: ;; (Observe (:pattern (some-pattern ...)) _)
;; ;;
;; (Observe (:pattern (some-pattern ...)) _) (expand-:pattern stx))
(analyse-pattern #'pat-stx)]))
(lambda (stx) (lambda (stx)
(syntax-case stx () (expand-:pattern stx)))
[(_ pat-stx)
(analyse-pattern #'pat-stx)])))
;;--------------------------------------------------------------------------- ;;---------------------------------------------------------------------------

2
syndicate/schema-compiler.rkt
View File

@ -67,6 +67,8 @@
(define (pat-pattern p) (define (pat-pattern p)
(match (unwrap p) (match (unwrap p)
[(NamedSimplePattern_ name (SimplePattern-embedded _))
`(:pattern ,(escape name) embedded)]
[(NamedSimplePattern_ name p) [(NamedSimplePattern_ name p)
`(:pattern ,(escape name))] `(:pattern ,(escape name))]
[(SimplePattern-any) discard] [(SimplePattern-any) discard]