176 lines
6.5 KiB
Scheme
176 lines
6.5 KiB
Scheme
#lang scheme/base
|
|
|
|
(require syntax/boundmap
|
|
syntax/stx
|
|
scheme/struct-info
|
|
"patterns.ss"
|
|
"compiler.ss"
|
|
"parse-helper.ss"
|
|
"parse-quasi.ss"
|
|
(only-in srfi/1 delete-duplicates)
|
|
(for-template (only-in "runtime.ss" matchable?)
|
|
scheme/base))
|
|
|
|
(provide parse/cert)
|
|
|
|
(define (ht-pat-transform p)
|
|
(syntax-case p ()
|
|
[(a b) #'(list a b)]
|
|
[x (identifier? #'x) #'x]))
|
|
|
|
;; parse : syntax -> Pat
|
|
;; compile stx into a pattern, using the new syntax
|
|
(define (parse/cert stx cert)
|
|
(define (parse stx) (parse/cert stx cert))
|
|
(syntax-case* stx (not var struct box cons list vector ? and or quote app
|
|
regexp pregexp list-rest list-no-order hash-table
|
|
quasiquote mcons list* mlist)
|
|
(lambda (x y) (eq? (syntax-e x) (syntax-e y)))
|
|
[(expander args ...)
|
|
(and (identifier? #'expander)
|
|
(match-expander? (syntax-local-value (cert #'expander)
|
|
(lambda () #f))))
|
|
(match-expander-transform
|
|
parse/cert cert #'expander stx match-expander-match-xform
|
|
"This expander only works with the legacy match syntax")]
|
|
[(var v)
|
|
(identifier? #'v)
|
|
(make-Var #'v)]
|
|
[(and p ...)
|
|
(make-And (map parse (syntax->list #'(p ...))))]
|
|
[(or p ...)
|
|
(let ([ps (map parse (syntax->list #'(p ...)))])
|
|
(all-vars ps stx)
|
|
(make-Or ps))]
|
|
[(not p ...)
|
|
;; nots are conjunctions of negations
|
|
(let ([ps (map (compose make-Not parse) (syntax->list #'(p ...)))])
|
|
(make-And ps))]
|
|
[(regexp r)
|
|
(trans-match #'matchable?
|
|
#'(lambda (e) (regexp-match r e))
|
|
(make-Pred #'values))]
|
|
[(regexp r p)
|
|
(trans-match #'matchable? #'(lambda (e) (regexp-match r e)) (parse #'p))]
|
|
[(pregexp r)
|
|
(trans-match #'matchable?
|
|
#'(lambda (e)
|
|
(regexp-match (if (pregexp? r) r (pregexp r)) e))
|
|
(make-Pred #'values))]
|
|
[(pregexp r p)
|
|
(trans-match #'matchable?
|
|
#'(lambda (e)
|
|
(regexp-match (if (pregexp? r) r (pregexp r)) e))
|
|
(parse #'p))]
|
|
[(box e) (make-Box (parse #'e))]
|
|
[(vector es ...)
|
|
(ormap ddk? (syntax->list #'(es ...)))
|
|
(trans-match #'vector?
|
|
#'vector->list
|
|
(parse (syntax/loc stx (list es ...))))]
|
|
[(vector es ...)
|
|
(make-Vector (map parse (syntax->list #'(es ...))))]
|
|
[(hash-table p ... dd)
|
|
(ddk? #'dd)
|
|
(trans-match
|
|
#'hash?
|
|
#'(lambda (e) (hash-map e list))
|
|
(with-syntax ([(elems ...)
|
|
(map ht-pat-transform (syntax->list #'(p ...)))])
|
|
(parse (syntax/loc stx (list-no-order elems ... dd)))))]
|
|
[(hash-table p ...)
|
|
(ormap ddk? (syntax->list #'(p ...)))
|
|
(raise-syntax-error
|
|
'match "dot dot k can only appear at the end of hash-table patterns" stx
|
|
(ormap (lambda (e) (and (ddk? e) e)) (syntax->list #'(p ...))))]
|
|
[(hash-table p ...)
|
|
(trans-match #'hash?
|
|
#'(lambda (e) (hash-map e list))
|
|
(with-syntax ([(elems ...)
|
|
(map ht-pat-transform
|
|
(syntax->list #'(p ...)))])
|
|
(parse (syntax/loc stx (list-no-order elems ...)))))]
|
|
[(hash-table . _)
|
|
(raise-syntax-error 'match "syntax error in hash-table pattern" stx)]
|
|
[(list-no-order p ... lp dd)
|
|
(ddk? #'dd)
|
|
(let* ([count (ddk? #'dd)]
|
|
[min (if (number? count) count #f)]
|
|
[max (if (number? count) count #f)]
|
|
[ps (syntax->list #'(p ...))])
|
|
(make-GSeq (cons (list (parse #'lp))
|
|
(for/list ([p ps]) (list (parse p))))
|
|
(cons min (map (lambda _ 1) ps))
|
|
(cons max (map (lambda _ 1) ps))
|
|
;; vars in lp are lists, vars elsewhere are not
|
|
(cons #f (map (lambda _ #t) ps))
|
|
(make-Null (make-Dummy (syntax/loc stx _)))
|
|
#f))]
|
|
[(list-no-order p ...)
|
|
(ormap ddk? (syntax->list #'(p ...)))
|
|
(raise-syntax-error
|
|
'match "dot dot k can only appear at the end of unordered match patterns"
|
|
stx
|
|
(ormap (lambda (e) (and (ddk? e) e)) (syntax->list #'(p ...))))]
|
|
[(list-no-order p ...)
|
|
(let ([ps (syntax->list #'(p ...))])
|
|
(make-GSeq (for/list ([p ps]) (list (parse p)))
|
|
(map (lambda _ 1) ps)
|
|
(map (lambda _ 1) ps)
|
|
;; all of these patterns get bound to only one thing
|
|
(map (lambda _ #t) ps)
|
|
(make-Null (make-Dummy (syntax/loc stx _)))
|
|
#f))]
|
|
[(list) (make-Null (make-Dummy (syntax/loc stx _)))]
|
|
[(mlist) (make-Null (make-Dummy (syntax/loc stx _)))]
|
|
[(list ..)
|
|
(ddk? #'..)
|
|
(raise-syntax-error 'match "incorrect use of ... in pattern" stx #'..)]
|
|
[(mlist ..)
|
|
(ddk? #'..)
|
|
(raise-syntax-error 'match "incorrect use of ... in pattern" stx #'..)]
|
|
[(list p .. . rest)
|
|
(ddk? #'..)
|
|
(dd-parse parse #'p #'.. (syntax/loc stx (list . rest)))]
|
|
[(mlist p .. . rest)
|
|
(ddk? #'..)
|
|
(dd-parse parse #'p #'.. (syntax/loc stx (list . rest)) #:mutable #t)]
|
|
[(list e es ...)
|
|
(make-Pair (parse #'e) (parse (syntax/loc stx (list es ...))))]
|
|
[(mlist e es ...)
|
|
(make-MPair (parse #'e) (parse (syntax/loc stx (mlist es ...))))]
|
|
[(list* . rest)
|
|
(parse (syntax/loc stx (list-rest . rest)))]
|
|
[(list-rest e)
|
|
(parse #'e)]
|
|
[(list-rest p dd . rest)
|
|
(ddk? #'dd)
|
|
(dd-parse parse #'p #'dd (syntax/loc stx (list-rest . rest)))]
|
|
[(list-rest e . es)
|
|
(make-Pair (parse #'e) (parse (syntax/loc #'es (list-rest . es))))]
|
|
[(cons e1 e2) (make-Pair (parse #'e1) (parse #'e2))]
|
|
[(mcons e1 e2) (make-MPair (parse #'e1) (parse #'e2))]
|
|
[(struct s pats)
|
|
(parse-struct stx cert parse #'s #'pats)]
|
|
[(? p q1 qs ...)
|
|
(make-And (cons (make-Pred (cert #'p))
|
|
(map parse (syntax->list #'(q1 qs ...)))))]
|
|
[(? p)
|
|
(make-Pred (cert #'p))]
|
|
[(app f p)
|
|
(make-App #'f (parse (cert #'p)))]
|
|
[(quasiquote p)
|
|
(parse-quasi #'p cert parse/cert)]
|
|
[(quasiquote . _)
|
|
(raise-syntax-error 'match "illegal use of quasiquote")]
|
|
[(quote . _)
|
|
(parse-quote stx parse)]
|
|
[x
|
|
(identifier? #'x)
|
|
(parse-id #'x)]
|
|
[v
|
|
(or (parse-literal (syntax-e #'v))
|
|
(raise-syntax-error 'match "syntax error in pattern" stx))]))
|
|
|
|
;; (trace parse)
|