diff --git a/collects/mzlib/private/match/match-error.ss b/collects/mzlib/private/match/match-error.ss index b0de1cb7de..f4e29e8a43 100644 --- a/collects/mzlib/private/match/match-error.ss +++ b/collects/mzlib/private/match/match-error.ss @@ -38,6 +38,9 @@ obj detail))) + (define (match:internal-err obj msg . detail) + (apply raise-syntax-error '|internal match error| msg obj detail)) + ;;!(function unreachable diff --git a/collects/mzlib/private/match/render-test-list-impl.ss b/collects/mzlib/private/match/render-test-list-impl.ss index 26da29af66..ca8fcaee53 100644 --- a/collects/mzlib/private/match/render-test-list-impl.ss +++ b/collects/mzlib/private/match/render-test-list-impl.ss @@ -166,12 +166,6 @@ ;; underscore is reserved to match nothing (_ '()) ;(ks sf bv let-bound)) - ;; plain identifiers expand into (var) patterns - (pt - (and (pattern-var? (syntax pt)) - (not (stx-dot-dot-k? (syntax pt)))) - (render-test-list #'(var pt) ae cert stx)) - ;; for variable patterns, we do bindings, and check if we've seen this variable before ((var pt) (identifier? (syntax pt)) @@ -194,9 +188,7 @@ (ks sf (cons (cons (syntax pt) ae) bv))])))))) ;; Recognize the empty list - ((list) (emit-null ae)) - ('() (emit-null ae)) - + ((list) (emit-null ae)) ;; This recognizes constants such strings [pt @@ -220,9 +212,6 @@ ,(syntax-object->datum p)) ae (lambda (exp) #`(equal? #,exp #,p))))) - (`quasi-pat - (render-test-list (parse-quasi #'quasi-pat) ae cert stx)) - ;; check for predicate patterns ;; could we check to see if a predicate is a procedure here? ((? pred?) @@ -231,10 +220,6 @@ ,(syntax-object->datum ae)) ae (lambda (exp) #`(#,(cert #'pred?) #,exp))))) - ;; predicate patterns with binders are redundant with and patterns - [(? pred? pats ...) - (render-test-list #'(and (? pred?) pats ...) ae cert stx)] - ;; syntax checking ((? anything ...) (match:syntax-err diff --git a/collects/mzlib/private/match/simplify-patterns.ss b/collects/mzlib/private/match/simplify-patterns.ss new file mode 100644 index 0000000000..f49592c77a --- /dev/null +++ b/collects/mzlib/private/match/simplify-patterns.ss @@ -0,0 +1,136 @@ +(module simplify-patterns mzscheme + + (require (lib "stx.ss" "syntax")) + (require (rename (lib "1.ss" "srfi") map-append append-map)) + + (require "match-error.ss" + "match-helper.ss" + "test-structure.scm" + "coupling-and-binding.scm" + "update-counts.scm" + "update-binding-counts.scm" + "reorder-tests.scm" + "match-expander-struct.ss" + "render-helpers.ss") + + (require "render-sigs.ss" + (lib "unitsig.ss")) + + (require-for-syntax "match-helper.ss" + "match-expander-struct.ss" + "test-no-order.ss") + + (require-for-template mzscheme + "match-error.ss" + "test-no-order.ss" + "match-helper.ss") + + (provide simplify) + + ;; simplifies patterns by removing syntactic sugar and expanding match-expanders + ;; simplify : syntax certifier-> syntax + (define (simplify stx cert) + (define (simplify/i stx) (simplify stx cert)) + (syntax-case* + stx + (_ list quote quasiquote vector box ? app and or not struct set! var + list-rest get! ... ___ unquote unquote-splicing cons + list-no-order hash-table regexp pregexp cons) stx-equal? + + ;; expand match-expanders + ;; this doesn't work because we need to keep the certifier around + [(expander args ...) + (and (identifier? #'expander) + (match-expander? (syntax-local-value (cert #'expander) (lambda () #f)))) + (let* ([expander (syntax-local-value (cert #'expander))] + [transformer (match-expander-plt-match-xform expander)]) + (unless transformer + (match:syntax-err #'expander + "This expander only works with the match.ss library.")) + (let* ([introducer (make-syntax-introducer)] + [certifier (match-expander-certifier expander)] + [result (introducer (transformer (introducer stx)))] + [cert* (lambda (id) (certifier (cert id) #f introducer))]) + (simplify result cert*)))] + + ;; label variable patterns + [id + (and (pattern-var? #'id) (not (stx-dot-dot-k? #'id))) + #'(var id)] + + ;; match the empty list + ['() (syntax/loc stx (list))] + + ;; other quoted data is untransformed + [(quote data) stx] + + ;; transform quasi-patterns into regular patterns + [`quasi-pat (simplify (parse-quasi #'quasi-pat))] + + ;; predicate patterns with binders are redundant with and patterns + [(? pred pat . pats) (simplify/i (syntax/loc stx (and (? pred) pat . pats)))] + [(? pred) (quasisyntax/loc stx (? #,(cert #'pred)))] + + ;; regexp patterns - FIXME: abstract here + [(regexp re) (simplify (syntax/loc stx (and (? string?) (? (lambda (x) (regexp-match re x))))))] + [(pregexp re) (simplify (syntax/loc stx (and (? string?) (? (lambda (x) (pregexp-match-with-error re x))))))] + [(regexp re pat) (simplify (syntax/loc stx (and (? string?) (app (lambda (x) (regexp-match re x)) pat))))] + [(pregexp re pat) (simplify (syntax/loc stx (and (? string?) (app (lambda (x) (pregexp-match-with-error re x)) pat))))] + [(regexp . re) (match:syntax-err stx "regexp pattern must have one or two subpatterns")] + [(pregexp . re) (match:syntax-err stx "pregexp pattern must have one or two subpatterns")] + + + ;; cons is just list-rest with 2 arguments + [(cons p1 p2) (simplify (syntax/loc stx (list-rest p1 p2)))] + [(cons . rest) (match:syntax-err stx "cons pattern must have exactly two subpatterns")] + + ;; aggregates + [(kw pats ...) + (memq (syntax-e #'kw) '(list vector list-rest list-no-order and or not)) + (quasisyntax/loc stx (kw #,@(syntax-map simplify #'(pats ...))))] + [(kw pats ... . rest) + (match:syntax-err stx (format "~a pattern must have a proper list of subpatterns" (syntax-e #'kw)))] + + ;; hash table patterns have their own syntax + [(hash-table (pat1 pat2) ...) + (with-syntax ([(pat1* ...) (syntax-map simplify #'(pat1 ...))] + [(pat2* ...) (syntax-map simplify #'(pat2 ...))]) + (syntax/loc stx (hash-table (pat1* pat2*) ...)))] + [(hash-table (pat1 pat2) ... ooo) + (stx-dot-dot-k? #'ooo) + (with-syntax ([(pat1* ...) (syntax-map simplify #'(pat1 ...))] + [(pat2* ...) (syntax-map simplify #'(pat2 ...))]) + (syntax/loc stx (hash-table (pat1* pat2*) ... ooo)))] + [(hash-table . rest) (match:syntax-err stx "syntax error in hash table pattern")] + + ;; struct patterns + [(struct st (pats ...)) (with-syntax ([(pats* ...) (syntax-map simplify #'(pats ...))] + [st* (cert #'st)]) + (syntax/loc stx (struct st* (pats* ...))))] + [(struct . rest) (match:syntax-err stx "syntax error in struct pattern")] + + [(box pat) (quasisyntax/loc stx (box #,(simplify #'pat)))] + [(box . rest) (match:syntax-err stx "syntax error in box pattern")] + + [(app e pat) (quasisyntax/loc stx (app #,(cert #'e) #,(simplify #'pat)))] + [(app . rest) (match:syntax-err stx "syntax error in app pattern")] + + [(set! id) + (identifier? #'id) + stx] + [(set! . rest) (match:syntax-err stx "set! pattern must have one identifier")] + + [(get! id) + (identifier? #'id) + stx] + [(get! . rest) (match:syntax-err stx "get! pattern must have one identifier")] + + [(var . rest) (match:internal-err stx "var pattern found before simplification!")] + + [_ stx]) + + + ) + + + ) \ No newline at end of file