94 lines
4.0 KiB
Racket
94 lines
4.0 KiB
Racket
#lang racket
|
|
|
|
(provide copy-raw-syntax-attribute
|
|
attribute-val/c)
|
|
|
|
(require version-case
|
|
stxparse-info/current-pvars
|
|
phc-toolkit/untyped
|
|
stxparse-info/parse
|
|
(for-syntax "optcontract.rkt"
|
|
racket/syntax
|
|
phc-toolkit/untyped
|
|
racket/function
|
|
stxparse-info/parse)
|
|
(for-syntax (only-in auto-syntax-e/utils make-auto-pvar)))
|
|
(version-case
|
|
[(version< (version) "6.90.0.24")
|
|
(require (only-in stxparse-info/parse/private/residual
|
|
[make-attribute-mapping
|
|
compat-make-attribute-mapping]))]
|
|
[else
|
|
(require (only-in stxparse-info/parse/private/residual ;; must be an absolute path
|
|
check-attr-value
|
|
[attribute-mapping -make-attribute-mapping]))
|
|
(define-for-syntax (compat-make-attribute-mapping valvar name depth syntax?)
|
|
(-make-attribute-mapping
|
|
valvar name depth (if syntax? #f (quote-syntax check-attr-value))))])
|
|
|
|
(begin-for-syntax
|
|
(define/contract (nest-map f last n)
|
|
(-> (-> syntax? syntax?) syntax? exact-nonnegative-integer? syntax?)
|
|
(if (= n 0)
|
|
last
|
|
(f (nest-map f last (sub1 n))))))
|
|
|
|
(define/contract (attribute-val/c depth [bottom-predicate any/c])
|
|
(->* {exact-nonnegative-integer?} {flat-contract?} flat-contract?)
|
|
(flat-named-contract
|
|
(build-compound-type-name 'attribute-val/c depth bottom-predicate)
|
|
(λ (l)
|
|
(if (= depth 0)
|
|
(or (false? l) (bottom-predicate l))
|
|
(or (false? l)
|
|
(and (list? l)
|
|
(andmap (attribute-val/c (sub1 depth)) l)))))))
|
|
|
|
(struct wrapped (value))
|
|
|
|
(define (attribute-wrap val depth)
|
|
(if (= depth 0)
|
|
(wrapped val)
|
|
(if val
|
|
(map (λ (v) (attribute-wrap v (sub1 depth)))
|
|
val)
|
|
#f)))
|
|
|
|
(define-syntax/parse (copy-raw-syntax-attribute name:id
|
|
attr-value:expr
|
|
ellipsis-depth:nat
|
|
syntax?:boolean)
|
|
;; the ~and is important, to prevent the nested ~or from being treated as
|
|
;; an ellipsis-head pattern.
|
|
#:with nested (nest-map (λ (pat) #`{~or #f ({~and #,pat} (... ...))})
|
|
(if (syntax-e #'syntax?)
|
|
#'{~or #f name}
|
|
;; Variable with empty name, so that the attribute
|
|
;; gets exported without a prefix.
|
|
;; Take care to keep the original srcloc,
|
|
;; otherwise error messages lack the proper srcloc
|
|
#`{~or #f {~var #,(datum->syntax #'name
|
|
'||
|
|
#'name)
|
|
extract-non-syntax}})
|
|
(syntax-e #'ellipsis-depth))
|
|
(if (syntax-e #'syntax?)
|
|
(with-syntax ([vtmp (generate-temporary #'name)]
|
|
[stmp (generate-temporary #'name)])
|
|
#'(begin
|
|
(define vtmp attr-value);; TODO: if already an id, no need to copy it (unless the id is mutated)
|
|
(define-syntax stmp
|
|
(compat-make-attribute-mapping (quote-syntax vtmp)
|
|
'name 'ellipsis-depth 'syntax?))
|
|
(define-syntax name
|
|
(make-auto-pvar 'ellipsis-depth (quote-syntax stmp)))
|
|
(define-pvars name)))
|
|
;; TODO ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ vvvvvvvvvvvvvvvvvvvvvvvvvv
|
|
#'(begin
|
|
(define-syntax-class extract-non-syntax
|
|
#:attributes (name)
|
|
(pattern v
|
|
#:attr name (wrapped-value (syntax-e #'v))))
|
|
(define/syntax-parse nested (attribute-wrap attr-value
|
|
ellipsis-depth)))))
|