397 lines
13 KiB
Racket
397 lines
13 KiB
Racket
#lang racket/base
|
|
(require "rep-attrs.rkt"
|
|
"kws.rkt"
|
|
unstable/struct
|
|
(for-syntax racket/base
|
|
syntax/stx
|
|
racket/syntax))
|
|
(provide (all-defined-out))
|
|
|
|
#|
|
|
Uses Arguments from kws.rkt
|
|
|#
|
|
|
|
#|
|
|
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
|
|
(pat:any Base)
|
|
(pat:var Base id id Arguments (listof IAttr) nat/#f bool)
|
|
(pat:literal Base identifier ct-phase ct-phase)
|
|
(pat:datum Base datum)
|
|
(pat:action Base ActionPattern SinglePattern)
|
|
(pat:head Base HeadPattern SinglePattern)
|
|
(pat:dots Base (listof EllipsisHeadPattern) SinglePattern)
|
|
(pat:and Base (listof SinglePattern))
|
|
(pat:or Base (listof SinglePattern))
|
|
(pat:not Base SinglePattern)
|
|
(pat:pair Base SinglePattern SinglePattern)
|
|
(pat:vector Base SinglePattern)
|
|
(pat:box Base SinglePattern)
|
|
(pat:pstruct Base key SinglePattern)
|
|
(pat:describe Base stx boolean SinglePattern)
|
|
(pat:delimit Base SinglePattern)
|
|
(pat:commit Base SinglePattern)
|
|
(pat:reflect Base stx Arguments (listof SAttr) id (listof IAttr))
|
|
(pat:post Base SinglePattern)
|
|
(pat:integrated Base id/#f Arguments id string)
|
|
|
|
A ListPattern is a subtype of SinglePattern; one of
|
|
(pat:datum Base '())
|
|
(pat:action Base ActionPattern ListPattern)
|
|
(pat:head Base HeadPattern ListPattern)
|
|
(pat:pair Base SinglePattern ListPattern)
|
|
(pat:dots Base EllipsisHeadPattern SinglePattern)
|
|
|#
|
|
|
|
(define-struct pat:any (attrs) #:prefab)
|
|
(define-struct pat:var (attrs name parser argu nested-attrs attr-count commit?) #:prefab)
|
|
(define-struct pat:literal (attrs id input-phase lit-phase) #:prefab)
|
|
(define-struct pat:datum (attrs datum) #:prefab)
|
|
(define-struct pat:action (attrs action 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:pair (attrs head tail) #:prefab)
|
|
(define-struct pat:vector (attrs pattern) #:prefab)
|
|
(define-struct pat:box (attrs pattern) #:prefab)
|
|
(define-struct pat:pstruct (attrs key pattern) #:prefab)
|
|
(define-struct pat:describe (attrs description transparent? pattern) #:prefab)
|
|
(define-struct pat:delimit (attrs pattern) #:prefab)
|
|
(define-struct pat:commit (attrs pattern) #:prefab)
|
|
(define-struct pat:reflect (attrs obj argu attr-decls name nested-attrs) #:prefab)
|
|
(define-struct pat:post (attrs pattern) #:prefab)
|
|
(define-struct pat:integrated (attrs name argu predicate description) #:prefab)
|
|
|
|
#|
|
|
A ActionPattern is one of
|
|
(action:cut Base)
|
|
(action:fail Base stx stx)
|
|
(action:bind Base (listof clause:attr))
|
|
* (action:and Base (listof ActionPattern))
|
|
(action:parse Base SinglePattern stx)
|
|
(action:do Base (listof stx))
|
|
(action:post Base ActionPattern)
|
|
|
|
action:and is desugared below in create-* procedures
|
|
|#
|
|
|
|
(define-struct action:cut (attrs) #:prefab)
|
|
(define-struct action:fail (attrs when message) #:prefab)
|
|
(define-struct action:bind (attrs clauses) #:prefab)
|
|
(define-struct action:and (attrs patterns) #:prefab)
|
|
(define-struct action:parse (attrs pattern expr) #:prefab)
|
|
(define-struct action:do (attrs stmts) #:prefab)
|
|
(define-struct action:post (attrs pattern) #:prefab)
|
|
|
|
#|
|
|
A HeadPattern is one of
|
|
(hpat:var Base id id Arguments (listof IAttr) nat/#f bool)
|
|
(hpat:seq Base ListPattern)
|
|
(hpat:action Base ActionPattern HeadPattern)
|
|
(hpat:and Base HeadPattern SinglePattern)
|
|
(hpat:or Base (listof HeadPattern))
|
|
(hpat:optional Base HeadPattern (listof clause:attr))
|
|
(hpat:describe Base stx/#f boolean HeadPattern)
|
|
(hpat:delimit Base HeadPattern)
|
|
(hpat:commit Base HeadPattern)
|
|
(hpat:reflect Base stx Arguments (listof SAttr) id (listof IAttr))
|
|
(hpat:post Base HeadPattern)
|
|
(hpat:peek Base HeadPattern)
|
|
(hpat:peek-not Base HeadPattern)
|
|
|#
|
|
|
|
(define-struct hpat:var (attrs name parser argu nested-attrs attr-count commit?) #:prefab)
|
|
(define-struct hpat:seq (attrs inner) #:prefab)
|
|
(define-struct hpat:action (attrs action 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)
|
|
(define-struct hpat:delimit (attrs pattern) #:prefab)
|
|
(define-struct hpat:commit (attrs pattern) #:prefab)
|
|
(define-struct hpat:reflect (attrs obj argu attr-decls name nested-attrs) #:prefab)
|
|
(define-struct hpat:post (attrs pattern) #:prefab)
|
|
(define-struct hpat:peek (attrs pattern) #:prefab)
|
|
(define-struct hpat:peek-not (attrs pattern) #:prefab)
|
|
|
|
#|
|
|
An EllipsisHeadPattern is
|
|
(ehpat Base HeadPattern RepConstraint)
|
|
|
|
A RepConstraint is one of
|
|
(rep:once stx stx stx)
|
|
(rep:optional stx stx (listof clause:attr))
|
|
(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 SideClause is one of
|
|
(clause:fail stx stx)
|
|
(clause:with pattern stx (listof stx))
|
|
(clause:attr IAttr stx)
|
|
(clause:do (listof stx))
|
|
|#
|
|
(define-struct clause:fail (condition message) #:prefab)
|
|
(define-struct clause:with (pattern expr definitions) #:prefab)
|
|
(define-struct clause:attr (attr expr) #:prefab)
|
|
(define-struct clause:do (stmts) #:prefab)
|
|
|
|
(define (pattern? x)
|
|
(or (pat:any? x)
|
|
(pat:var? x)
|
|
(pat:literal? x)
|
|
(pat:datum? x)
|
|
(pat:action? x)
|
|
(pat:head? x)
|
|
(pat:dots? x)
|
|
(pat:and? x)
|
|
(pat:or? x)
|
|
(pat:not? x)
|
|
(pat:pair? x)
|
|
(pat:vector? x)
|
|
(pat:box? x)
|
|
(pat:pstruct? x)
|
|
(pat:describe? x)
|
|
(pat:delimit? x)
|
|
(pat:commit? x)
|
|
(pat:reflect? x)
|
|
(pat:post? x)
|
|
(pat:integrated? x)))
|
|
|
|
(define (action-pattern? x)
|
|
(or (action:cut? x)
|
|
(action:bind? x)
|
|
(action:fail? x)
|
|
(action:and? x)
|
|
(action:parse? x)
|
|
(action:do? x)
|
|
(action:post? x)))
|
|
|
|
(define (head-pattern? x)
|
|
(or (hpat:var? x)
|
|
(hpat:seq? x)
|
|
(hpat:action? x)
|
|
(hpat:and? x)
|
|
(hpat:or? x)
|
|
(hpat:optional? x)
|
|
(hpat:describe? x)
|
|
(hpat:delimit? x)
|
|
(hpat:commit? x)
|
|
(hpat:reflect? x)
|
|
(hpat:post? x)
|
|
(hpat:peek? x)
|
|
(hpat:peek-not? 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 (in-list (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:action pat:head
|
|
pat:dots pat:and pat:or pat:not pat:describe
|
|
pat:pair pat:vector pat:box pat:pstruct
|
|
pat:delimit pat:commit pat:reflect pat:post pat:integrated
|
|
action:cut action:bind action:fail action:and action:parse
|
|
action:do action:post
|
|
hpat:var hpat:seq hpat:action hpat:and hpat:or hpat:describe
|
|
hpat:optional hpat:delimit hpat:commit hpat:reflect hpat:post
|
|
hpat:peek hpat:peek-not
|
|
ehpat)))
|
|
|
|
;; ----
|
|
|
|
;; Helpers to handle attribute calculations
|
|
;; Too complicated for a few pattern forms; those are handled in rep.rkt
|
|
|
|
(define (create-pat:any)
|
|
(make pat:any null))
|
|
|
|
(define (create-pat:var name parser argu nested-attrs attr-count commit?)
|
|
(let ([attrs
|
|
(if name (cons (make attr name 0 #t) nested-attrs) nested-attrs)])
|
|
(make pat:var attrs name parser argu nested-attrs attr-count commit?)))
|
|
|
|
(define (create-pat:reflect obj argu attr-decls name nested-attrs)
|
|
(let ([attrs
|
|
(if name (cons (make attr name 0 #t) nested-attrs) nested-attrs)])
|
|
(make pat:reflect attrs obj argu attr-decls name nested-attrs)))
|
|
|
|
(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:action g sp)
|
|
(cond [(action:and? g)
|
|
(for/fold ([sp sp]) ([g (in-list (reverse (action:and-patterns g)))])
|
|
(create-pat:action g sp))]
|
|
[else
|
|
(let ([attrs (append-iattrs (map pattern-attrs (list g sp)))])
|
|
(make pat:action 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:pair headp tailp)
|
|
(make pat:pair (append-iattrs (map pattern-attrs (list headp tailp))) headp tailp))
|
|
|
|
(define (create-pat:vector pattern)
|
|
(make pat:vector (pattern-attrs pattern) pattern))
|
|
|
|
(define (create-pat:box pattern)
|
|
(make pat:box (pattern-attrs pattern) pattern))
|
|
|
|
(define (create-pat:pstruct key pattern)
|
|
(make pat:pstruct (pattern-attrs pattern) key pattern))
|
|
|
|
(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-pat:delimit pattern)
|
|
(make pat:delimit (pattern-attrs pattern) pattern))
|
|
|
|
(define (create-pat:commit pattern)
|
|
(make pat:commit (pattern-attrs pattern) pattern))
|
|
|
|
(define (create-pat:post pattern)
|
|
(make pat:post (pattern-attrs pattern) pattern))
|
|
|
|
(define (create-pat:integrated name argu predicate description)
|
|
(let ([attrs (if name (list (make attr name 0 #t)) null)])
|
|
(make pat:integrated attrs name argu predicate description)))
|
|
|
|
;; ----
|
|
|
|
(define (create-action:cut)
|
|
(make action:cut null))
|
|
|
|
(define (create-action:fail condition message)
|
|
(make action:fail null condition message))
|
|
|
|
(define (create-action:bind clauses)
|
|
(make action:bind (map clause:attr-attr clauses) clauses))
|
|
|
|
(define (create-action:and patterns)
|
|
(let ([attrs (append-iattrs (map pattern-attrs patterns))])
|
|
(make action:and attrs patterns)))
|
|
|
|
(define (create-action:parse pattern expr)
|
|
(make action:parse (pattern-attrs pattern) pattern expr))
|
|
|
|
(define (create-action:do stmts)
|
|
(make action:do null stmts))
|
|
|
|
(define (create-action:post pattern)
|
|
(make action:post (pattern-attrs pattern) pattern))
|
|
|
|
;; ----
|
|
|
|
(define (create-hpat:var name parser argu nested-attrs attr-count commit?)
|
|
(let ([attrs
|
|
(if name (cons (make attr name 0 #t) nested-attrs) nested-attrs)])
|
|
(make hpat:var attrs name parser argu nested-attrs attr-count commit?)))
|
|
|
|
(define (create-hpat:reflect obj argu attr-decls name nested-attrs)
|
|
(let ([attrs
|
|
(if name (cons (make attr name 0 #t) nested-attrs) nested-attrs)])
|
|
(make hpat:reflect attrs obj argu attr-decls name nested-attrs)))
|
|
|
|
(define (create-hpat:seq lp)
|
|
(make hpat:seq (pattern-attrs lp) lp))
|
|
|
|
(define (create-hpat:action g hp)
|
|
(cond [(action:and? g)
|
|
(for/fold ([hp hp]) ([g (in-list (reverse (action:and-patterns g)))])
|
|
(create-hpat:action g hp))]
|
|
[else
|
|
(let ([attrs (append-iattrs (map pattern-attrs (list g hp)))])
|
|
(make hpat:action 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 (create-hpat:delimit pattern)
|
|
(make hpat:delimit (pattern-attrs pattern) pattern))
|
|
|
|
(define (create-hpat:commit pattern)
|
|
(make hpat:commit (pattern-attrs pattern) pattern))
|
|
|
|
(define (create-hpat:post pattern)
|
|
(make hpat:post (pattern-attrs pattern) pattern))
|
|
|
|
(define (create-hpat:peek pattern)
|
|
(make hpat:peek (pattern-attrs pattern) pattern))
|
|
|
|
(define (create-hpat:peek-not pattern)
|
|
(make hpat:peek-not null pattern))
|
|
|
|
;; ----
|
|
|
|
(define (action/head-pattern->list-pattern p)
|
|
(cond [(action-pattern? p)
|
|
(create-pat:action 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 (action-pattern->single-pattern gp)
|
|
(create-pat:action gp (create-pat:any)))
|