281 lines
8.9 KiB
Racket
281 lines
8.9 KiB
Racket
#lang scheme/base
|
|
(require "rep-attrs.ss"
|
|
unstable/struct
|
|
(for-syntax scheme/base
|
|
syntax/stx
|
|
unstable/syntax))
|
|
(provide (all-defined-out))
|
|
|
|
#|
|
|
A Base is (listof IAttr)
|
|
If P = (make-pattern Attrs ...) and A is in Attrs,
|
|
the depth of A is with respect to P,
|
|
not with respect to the entire enclosing pattern.
|
|
|#
|
|
|
|
#|
|
|
A SinglePattern is one of
|
|
(make-pat:any Base)
|
|
(make-pat:var Base id id (listof stx) (listof IAttr) bool)
|
|
(make-pat:literal Base identifier ct-phase ct-phase)
|
|
(make-pat:datum Base datum)
|
|
(make-pat:ghost Base GhostPattern SinglePattern)
|
|
(make-pat:head Base HeadPattern SinglePattern)
|
|
(make-pat:dots Base (listof EllipsisHeadPattern) SinglePattern)
|
|
(make-pat:and Base (listof SinglePattern))
|
|
(make-pat:or Base (listof SinglePattern))
|
|
(make-pat:not Base SinglePattern)
|
|
(make-pat:compound Base Kind (listof SinglePattern))
|
|
(make-pat:describe Base stx boolean SinglePattern)
|
|
|
|
A ListPattern is a subtype of SinglePattern; one of
|
|
(make-pat:datum Base '())
|
|
(make-pat:ghost Base GhostPattern ListPattern)
|
|
(make-pat:head Base HeadPattern ListPattern)
|
|
(make-pat:compound Base '#:pair (list SinglePattern ListPattern))
|
|
(make-pat:dots Base EllipsisHeadPattern SinglePattern)
|
|
|#
|
|
|
|
(define-struct pat:any (attrs) #:prefab)
|
|
(define-struct pat:var (attrs name parser args nested-attrs commit?) #:prefab)
|
|
(define-struct pat:literal (attrs id input-phase lit-phase) #:prefab)
|
|
(define-struct pat:datum (attrs datum) #:prefab)
|
|
(define-struct pat:ghost (attrs ghost inner) #:prefab)
|
|
(define-struct pat:head (attrs head tail) #:prefab)
|
|
(define-struct pat:dots (attrs heads tail) #:prefab)
|
|
(define-struct pat:and (attrs patterns) #:prefab)
|
|
(define-struct pat:or (attrs patterns) #:prefab)
|
|
(define-struct pat:not (attrs pattern) #:prefab)
|
|
(define-struct pat:compound (attrs kind patterns) #:prefab)
|
|
(define-struct pat:describe (attrs description transparent? pattern) #:prefab)
|
|
|
|
#|
|
|
A GhostPattern is one of
|
|
(make-ghost:cut Base)
|
|
(make-ghost:fail Base bool stx stx)
|
|
(make-ghost:bind Base (listof clause:attr))
|
|
* (make-ghost:and Base (listof GhostPattern))
|
|
(make-ghost:parse Base SinglePattern stx)
|
|
|
|
ghost:and is desugared below in create-* procedures
|
|
|#
|
|
|
|
(define-struct ghost:cut (attrs) #:prefab)
|
|
(define-struct ghost:fail (attrs early? when message) #:prefab)
|
|
(define-struct ghost:bind (attrs clauses) #:prefab)
|
|
(define-struct ghost:and (attrs patterns) #:prefab)
|
|
(define-struct ghost:parse (attrs pattern expr) #:prefab)
|
|
|
|
#|
|
|
A HeadPattern is one of
|
|
(make-hpat:var Base id id (listof stx) (listof IAttr) bool)
|
|
(make-hpat:seq Base ListPattern)
|
|
(make-hpat:ghost Base GhostPattern HeadPattern)
|
|
(make-hpat:and Base HeadPattern SinglePattern)
|
|
(make-hpat:or Base (listof HeadPattern))
|
|
(make-hpat:optional Base HeadPattern (listof clause:attr))
|
|
(make-hpat:describe Base stx/#f boolean HeadPattern)
|
|
|#
|
|
|
|
(define-struct hpat:var (attrs name parser args nested-attrs commit?) #:prefab)
|
|
(define-struct hpat:seq (attrs inner) #:prefab)
|
|
(define-struct hpat:ghost (attrs ghost inner) #:prefab)
|
|
(define-struct hpat:and (attrs head single) #:prefab)
|
|
(define-struct hpat:or (attrs patterns) #:prefab)
|
|
(define-struct hpat:optional (attrs inner defaults) #:prefab)
|
|
(define-struct hpat:describe (attrs description transparent? pattern) #:prefab)
|
|
|
|
#|
|
|
An EllipsisHeadPattern is
|
|
(make-ehpat Base HeadPattern RepConstraint)
|
|
|
|
A RepConstraint is one of
|
|
(make-rep:once stx stx stx)
|
|
(make-rep:optional stx stx (listof clause:attr))
|
|
(make-rep:bounds nat/#f nat/#f stx stx stx)
|
|
#f
|
|
|#
|
|
|
|
(define-struct ehpat (attrs head repc) #:prefab)
|
|
(define-struct rep:once (name under-message over-message) #:prefab)
|
|
(define-struct rep:optional (name over-message defaults) #:prefab)
|
|
(define-struct rep:bounds (min max name under-message over-message) #:prefab)
|
|
|
|
|
|
#|
|
|
A Kind is one of
|
|
'#:pair
|
|
'#:box
|
|
'#:vector
|
|
(list '#:pstruct prefab-struct-key)
|
|
|#
|
|
|
|
(define (pattern? x)
|
|
(or (pat:any? x)
|
|
(pat:var? x)
|
|
(pat:literal? x)
|
|
(pat:datum? x)
|
|
(pat:ghost? x)
|
|
(pat:head? x)
|
|
(pat:dots? x)
|
|
(pat:and? x)
|
|
(pat:or? x)
|
|
(pat:not? x)
|
|
(pat:compound? x)
|
|
(pat:describe? x)))
|
|
|
|
(define (ghost-pattern? x)
|
|
(or (ghost:cut? x)
|
|
(ghost:bind? x)
|
|
(ghost:fail? x)
|
|
(ghost:and? x)
|
|
(ghost:parse? x)))
|
|
|
|
(define (head-pattern? x)
|
|
(or (hpat:var? x)
|
|
(hpat:seq? x)
|
|
(hpat:ghost? x)
|
|
(hpat:and? x)
|
|
(hpat:or? x)
|
|
(hpat:optional? x)
|
|
(hpat:describe? x)))
|
|
|
|
(define (ellipsis-head-pattern? x)
|
|
(ehpat? x))
|
|
|
|
(define single-pattern? pattern?)
|
|
|
|
(define (single-or-head-pattern? x)
|
|
(or (single-pattern? x)
|
|
(head-pattern? x)))
|
|
|
|
(define pattern-attrs
|
|
(let ()
|
|
(define-syntax (mk-get-attrs stx)
|
|
(syntax-case stx ()
|
|
[(_ struct ...)
|
|
(with-syntax
|
|
([([pred accessor] ...)
|
|
(for/list ([s (stx->list #'(struct ...))])
|
|
(list (format-id s "~a?" (syntax-e s))
|
|
(format-id s "~a-attrs" (syntax-e s))))])
|
|
#'(lambda (x)
|
|
(cond [(pred x) (accessor x)] ...
|
|
[else (raise-type-error 'pattern-attrs "pattern" x)])))]))
|
|
(mk-get-attrs pat:any pat:var pat:datum pat:literal pat:ghost pat:head
|
|
pat:dots pat:and pat:or pat:not pat:compound pat:describe
|
|
ghost:cut ghost:bind ghost:fail ghost:and ghost:parse
|
|
hpat:var hpat:seq hpat:ghost hpat:and hpat:or hpat:describe
|
|
hpat:optional
|
|
ehpat)))
|
|
|
|
|
|
;; ----
|
|
|
|
;; Helpers to handle attribute calculations
|
|
;; Too complicated for a few pattern forms; those are handled in rep.ss
|
|
|
|
(define (create-pat:any)
|
|
(make pat:any null))
|
|
|
|
(define (create-pat:var name parser args nested-attrs commit?)
|
|
(let ([attrs
|
|
(if name (cons (make attr name 0 #t) nested-attrs) nested-attrs)])
|
|
(make pat:var attrs name parser args nested-attrs commit?)))
|
|
|
|
(define (create-pat:datum datum)
|
|
(make pat:datum null datum))
|
|
|
|
(define (create-pat:literal literal input-phase lit-phase)
|
|
(make pat:literal null literal input-phase lit-phase))
|
|
|
|
(define (create-pat:ghost g sp)
|
|
(cond [(ghost:and? g)
|
|
(for/fold ([sp sp]) ([g (reverse (ghost:and-patterns g))])
|
|
(create-pat:ghost g sp))]
|
|
[else
|
|
(let ([attrs (append-iattrs (map pattern-attrs (list g sp)))])
|
|
(make pat:ghost attrs g sp))]))
|
|
|
|
(define (create-pat:head headp tailp)
|
|
(let ([attrs (append-iattrs (map pattern-attrs (list headp tailp)))])
|
|
(make pat:head attrs headp tailp)))
|
|
|
|
(define (create-pat:compound kind ps)
|
|
(make pat:compound (append-iattrs (map pattern-attrs ps)) kind ps))
|
|
|
|
(define (create-pat:describe description transparent? p)
|
|
(make pat:describe (pattern-attrs p) description transparent? p))
|
|
|
|
(define (create-pat:and patterns)
|
|
(let ([attrs (append-iattrs (map pattern-attrs patterns))])
|
|
(make pat:and attrs patterns)))
|
|
|
|
(define (create-pat:or patterns)
|
|
(let ([attrs (union-iattrs (map pattern-attrs patterns))])
|
|
(make pat:or attrs patterns)))
|
|
|
|
(define (create-pat:not pattern)
|
|
(make pat:not null pattern))
|
|
|
|
(define (create-pat:dots headps tailp)
|
|
(let ([attrs (append-iattrs (map pattern-attrs (cons tailp headps)))])
|
|
(make pat:dots attrs headps tailp)))
|
|
|
|
;; ----
|
|
|
|
(define (create-ghost:cut)
|
|
(make ghost:cut null))
|
|
|
|
(define (create-ghost:fail early? condition message)
|
|
(make ghost:fail null early? condition message))
|
|
|
|
(define (create-ghost:and patterns)
|
|
(let ([attrs (append-iattrs (map pattern-attrs patterns))])
|
|
(make ghost:and attrs patterns)))
|
|
|
|
(define (create-ghost:parse pattern expr)
|
|
(make ghost:parse (pattern-attrs pattern) pattern expr))
|
|
|
|
;; ----
|
|
|
|
(define (create-hpat:var name parser args nested-attrs commit?)
|
|
(let ([attrs
|
|
(if name (cons (make attr name 0 #t) nested-attrs) nested-attrs)])
|
|
(make hpat:var attrs name parser args nested-attrs commit?)))
|
|
|
|
(define (create-hpat:seq lp)
|
|
(make hpat:seq (pattern-attrs lp) lp))
|
|
|
|
(define (create-hpat:ghost g hp)
|
|
(cond [(ghost:and? g)
|
|
(for/fold ([hp hp]) ([g (reverse (ghost:and-patterns g))])
|
|
(create-hpat:ghost g hp))]
|
|
[else
|
|
(let ([attrs (append-iattrs (map pattern-attrs (list g hp)))])
|
|
(make hpat:ghost attrs g hp))]))
|
|
|
|
(define (create-hpat:describe description transparent? p)
|
|
(make hpat:describe (pattern-attrs p) description transparent? p))
|
|
|
|
(define (create-hpat:and hp sp)
|
|
(make hpat:and (append-iattrs (map pattern-attrs (list hp sp))) hp sp))
|
|
|
|
(define (create-hpat:or patterns)
|
|
(let ([attrs (union-iattrs (map pattern-attrs patterns))])
|
|
(make hpat:or attrs patterns)))
|
|
|
|
;; ----
|
|
|
|
(define (ghost/head-pattern->list-pattern p)
|
|
(cond [(ghost-pattern? p)
|
|
(create-pat:ghost p (create-pat:any))]
|
|
[(hpat:seq? p)
|
|
;; simplification: just extract list pattern from hpat:seq
|
|
(hpat:seq-inner p)]
|
|
[else
|
|
(create-pat:head p (create-pat:datum '()))]))
|
|
|
|
(define (ghost-pattern->single-pattern gp)
|
|
(create-pat:ghost gp (create-pat:any)))
|