commit cf92b0fc32a3bc3009c876332bab7135f379514e
parent e4b3235a596543a8969a950e686b24c003a85f56
Author: Georges Dupéron <georges.duperon@gmail.com>
Date: Thu, 26 Jan 2017 23:25:05 +0100
Closes FB case 186 Trigger error when stxparse-info is not active (use get-shadower and compare the ids)
Diffstat:
2 files changed, 145 insertions(+), 44 deletions(-)
diff --git a/main.rkt b/main.rkt
@@ -4,11 +4,13 @@
phc-toolkit/untyped
racket/stxparam
stxparse-info/parse
+ stxparse-info/case
stxparse-info/current-pvars
stxparse-info/parse/experimental/template
syntax/id-table
- racket/syntax
+ (subtract-in racket/syntax stxparse-info/case)
(for-syntax "patch-arrows.rkt"
+ racket/format
stxparse-info/parse
racket/private/sc
racket/syntax
@@ -171,53 +173,81 @@
(car depths)
#'check-ellipsis-count-ddd))))
-(define-for-syntax/case-args ((sub*template tmpl-form)
- (self tmpl . maybe-props))
- (define acc '())
+(define-for-syntax (sub*template self-form tmpl-form)
+ (syntax-parser
+ [(self {~optional {~and #:force-no-stxinfo force-no-stxinfo}}
+ {~optional {~and #:props maybe-props}}
+ ;; #: marks end of options (so that we can have implicit ?@ later)
+ {~optional #:}
+ tmpl)
+ (unless (attribute force-no-stxinfo)
+ (for ([sym (in-list '(syntax-parse define/syntax-parse syntax-parser
+ syntax-case define/with-syntax with-syntax))])
+ (let ([shadower (syntax-local-get-shadower (datum->syntax #'self sym))]
+ [good (datum->syntax #'here sym)])
+ (when (or (not (identifier-binding shadower))
+ (not (free-identifier=? shadower good)))
+ (raise-syntax-error self-form
+ (~a sym (if (identifier-binding shadower)
+ (~a " resolves to the official "
+ sym ",")
+ " seems undefined,")
+ " but subtemplate needs the patched"
+ " version from stxparse-info. Use (require"
+ " stxparse-info/parse) and (require"
+ " stxparse-info/case) to fix this. This"
+ " message can be disabled with (" self-form
+ " #:force-no-stxinfo …), if you know what"
+ " you're doing."))))))
+
+ (define acc '())
- ;; Finds identifiers of the form zᵢ, and return a list of existing xᵢ bindings
- (define (fold-process stx rec)
- (syntax-case stx ()
- [(id . _) (and (identifier? #'id)
- (free-identifier=? #'id #'unsyntax))
- stx]
- [id (identifier? #'id)
- (let ([binders+info (find-subscript-binder #'id)])
- (when binders+info
- (set! acc (cons binders+info acc)))
- #'id)]
- [other (rec #'other)]))
- ;; Process the syntax, extract the derived bindings into acc
- ;; Does not take zᵢ identifiers generated by template metafunctions into
- ;; account for now.
- (fold-syntax fold-process #'tmpl)
+ ;; Finds identifiers of the form zᵢ, and return a list of existing xᵢ
+ ;; bindings
+ (define (fold-process stx rec)
+ (syntax-case stx ()
+ [(id . _) (and (identifier? #'id)
+ (free-identifier=? #'id #'unsyntax))
+ stx]
+ [id (identifier? #'id)
+ (let ([binders+info (find-subscript-binder #'id)])
+ (when binders+info
+ (set! acc (cons binders+info acc)))
+ #'id)]
+ [other (rec #'other)]))
+ ;; Process the syntax, extract the derived bindings into acc
+ ;; Does not take zᵢ identifiers generated by template metafunctions into
+ ;; account for now.
+ (fold-syntax fold-process #'tmpl)
- ;; define the result, which looks like (template . tmpl) or
- ;; like (quasitemplate . tmpl)
- (define result
- (quasisyntax/top-loc #'self
- (#,tmpl-form tmpl . maybe-props)))
- ;; Make sure that we remove duplicates, otherwise we'll get errors if we
- ;; define the same derived id twice.
- (define/with-syntax ([bound
- binders
- unique-at-runtime-ids
- ellipsis-depth
- check-ellipsis-count]
- …)
- (remove-duplicates acc bound-identifier=? #:key car))
+ ;; define the result, which looks like (template . tmpl) or
+ ;; like (quasitemplate . tmpl)
+ (define result
+ (quasisyntax/top-loc #'self
+ (#,tmpl-form tmpl #,@(when-attr maybe-props #'{#:props maybe-props}))))
+ ;; Make sure that we remove duplicates, otherwise we'll get errors if we
+ ;; define the same derived id twice.
+ (define/with-syntax ([bound
+ binders
+ unique-at-runtime-ids
+ ellipsis-depth
+ check-ellipsis-count]
+ …)
+ (remove-duplicates acc bound-identifier=? #:key car))
- #`(let ()
- (derive bound binders unique-at-runtime-ids ellipsis-depth)
- …
- (let ()
- ;; no-op, just to raise an error when they are incompatible
- #'(check-ellipsis-count …) ;; TODO: allow #f values for ~optional in syntax/parse ;;;;;;;;;;;;;;
- ;; actually call template or quasitemplate
- #,result)))
+ #`(let ()
+ (derive bound binders unique-at-runtime-ids ellipsis-depth)
+ …
+ (let ()
+ ;; no-op, just to raise an error when they are incompatible
+ #'(check-ellipsis-count …) ;; TODO: allow #f values for ~optional in syntax/parse ;;;;;;;;;;;;;;
+ ;; actually call template or quasitemplate
+ #,result))]))
-(define-syntax subtemplate (sub*template #'template))
-(define-syntax quasisubtemplate (sub*template #'quasitemplate))
+(define-syntax subtemplate
+ (sub*template 'subtemplate #'template))
+(define-syntax quasisubtemplate
+ (sub*template 'quasisubtemplate #'quasitemplate))
(define/contract (multi-hash-ref! h keys to-set)
;; This assumes that the hash does not get mutated during the execution of
diff --git a/test/test-subtemplate-detect-stxinfo.rkt b/test/test-subtemplate-detect-stxinfo.rkt
@@ -0,0 +1,71 @@
+#lang racket
+(module m-ok racket
+ (require subtemplate
+ stxparse-info/parse
+ stxparse-info/case
+ rackunit
+ syntax/macro-testing)
+ (check-not-exn
+ (λ ()
+ (convert-compile-time-error
+ (subtemplate ok)))))
+
+(module m-no-parse racket
+ (require subtemplate
+ stxparse-info/case
+ rackunit
+ syntax/macro-testing)
+ (check-exn #rx"subtemplate: syntax-parse seems undefined,"
+ (λ ()
+ (convert-compile-time-error
+ (subtemplate ok)))))
+
+(module m-wrong-parse racket
+ (require subtemplate
+ syntax/parse
+ stxparse-info/case
+ rackunit
+ syntax/macro-testing)
+ (check-exn
+ #rx"subtemplate: syntax-parse resolves to the official syntax-parse,"
+ (λ ()
+ (convert-compile-time-error
+ (subtemplate ok)))))
+
+(module m-wrong-case racket
+ (require subtemplate
+ stxparse-info/parse
+ rackunit
+ syntax/macro-testing)
+ (check-exn #rx"subtemplate: syntax-case resolves to the official syntax-case,"
+ (λ ()
+ (convert-compile-time-error
+ (subtemplate ok)))))
+
+(module m-no-parse-wrong-case racket
+ (require subtemplate
+ rackunit
+ syntax/macro-testing)
+ (check-exn #rx"subtemplate: syntax-parse seems undefined,"
+ (λ ()
+ (convert-compile-time-error
+ (subtemplate ok)))))
+
+(module m-wrong-parse-wrong-case racket
+ (require subtemplate
+ syntax/parse
+ rackunit
+ syntax/macro-testing)
+ (check-exn
+ #rx"subtemplate: syntax-parse resolves to the official syntax-parse,"
+ (λ ()
+ (convert-compile-time-error
+ (subtemplate ok)))))
+
+
+(require 'm-ok)
+(require 'm-no-parse)
+(require 'm-wrong-parse)
+(require 'm-wrong-case)
+(require 'm-no-parse-wrong-case)
+(require 'm-wrong-parse-wrong-case)
