You cannot select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
217 lines
8.2 KiB
Racket
217 lines
8.2 KiB
Racket
#lang racket/base
|
|
(require brag/rules/stx-types
|
|
racket/list
|
|
(for-syntax racket/base))
|
|
(provide flatten-rule
|
|
flatten-rules
|
|
prim-rule)
|
|
|
|
(define (make-fresh-name)
|
|
(let ([n 0])
|
|
(λ ()
|
|
(set! n (add1 n))
|
|
(string->symbol (format "%rule~a" n)))))
|
|
|
|
(define default-fresh-name (make-fresh-name))
|
|
|
|
|
|
;; Translates rules to lists of primitive rules.
|
|
|
|
|
|
(define (flatten-rules rules #:fresh-name [fresh-name default-fresh-name])
|
|
(define ht (make-hasheq))
|
|
(apply append (for/list ([a-rule (in-list rules)])
|
|
(flatten-rule a-rule
|
|
#:ht ht
|
|
#:fresh-name fresh-name))))
|
|
|
|
|
|
;; flatten-rule: rule -> (listof primitive-rule)
|
|
(define (flatten-rule a-rule
|
|
#:fresh-name [fresh-name default-fresh-name]
|
|
;; ht: (hashtableof pattern-hash-key pat)
|
|
#:ht [ht (make-hasheq)])
|
|
|
|
(let recur ([a-rule a-rule] [inferred? #f])
|
|
|
|
;; lift-nonprimitive-pattern: pattern -> (values (listof primitive-rule) pattern)
|
|
;; Turns non-primitive patterns into primitive patterns, and produces a set of
|
|
;; derived rules.
|
|
(define (lift-nonprimitive-pattern a-pat)
|
|
(cond
|
|
[(primitive-pattern? a-pat)
|
|
(values '() (linearize-primitive-pattern a-pat))]
|
|
[(hash-has-key? ht (pattern->hash-key a-pat))
|
|
(values '() (list (hash-ref ht (pattern->hash-key a-pat))))]
|
|
[else
|
|
(define head (syntax-case a-pat () [(head rest ...) #'head]))
|
|
(define new-name (datum->syntax #f (fresh-name) a-pat))
|
|
(define new-inferred-id (datum->syntax #f `(inferred-id ,new-name ,head) a-pat))
|
|
(hash-set! ht (pattern->hash-key a-pat) new-inferred-id)
|
|
(values (recur #`(rule #,new-name #,a-pat) head)
|
|
(list new-inferred-id))]))
|
|
|
|
(define (lift-nonprimitive-patterns pats)
|
|
(define-values (rules patterns)
|
|
(for/fold ([inferred-ruless '()]
|
|
[patternss '()])
|
|
([p (in-list pats)])
|
|
(define-values (new-rules new-ps)
|
|
(lift-nonprimitive-pattern p))
|
|
(values (cons new-rules inferred-ruless)
|
|
(cons new-ps patternss))))
|
|
(values (apply append (reverse rules))
|
|
(apply append (reverse patterns))))
|
|
|
|
(with-syntax ([HEAD (if inferred? #'inferred-prim-rule #'prim-rule)]
|
|
[ORIGIN (syntax-case a-rule (rule) [(rule name (pat-head rest ...)) #'pat-head])])
|
|
(syntax-case a-rule (rule)
|
|
[(rule NAME PAT)
|
|
(syntax-case #'PAT (id inferred-id lit token choice repeat maybe seq)
|
|
|
|
;; The primitive types stay as they are:
|
|
[(id val)
|
|
(list #'(HEAD ORIGIN NAME [PAT]))]
|
|
[(inferred-id val reason)
|
|
(list #'(HEAD ORIGIN NAME [PAT]))]
|
|
[(lit val)
|
|
(list #'(HEAD ORIGIN NAME [PAT]))]
|
|
[(token val)
|
|
(list #'(HEAD ORIGIN NAME [PAT]))]
|
|
|
|
|
|
;; Everything else might need lifting:
|
|
[(choice SUB-PAT ...)
|
|
(begin
|
|
(define-values (inferred-ruless/rev new-sub-patss/rev)
|
|
(for/fold ([rs '()] [ps '()])
|
|
([p (syntax->list #'(SUB-PAT ...))])
|
|
(let-values ([(new-r new-p)
|
|
(lift-nonprimitive-pattern p)])
|
|
(values (cons new-r rs) (cons new-p ps)))))
|
|
(with-syntax ([((SUB-PAT ...) ...) (reverse new-sub-patss/rev)])
|
|
(append (list #'(HEAD ORIGIN NAME [SUB-PAT ...] ...))
|
|
(apply append (reverse inferred-ruless/rev)))))]
|
|
|
|
[(repeat 0 0 SUB-PAT)
|
|
;; repeat from 0 to 0 (is a no-op)
|
|
(recur #'(rule NAME (seq)) #f)]
|
|
|
|
[(repeat 0 MAYBE-MAX SUB-PAT)
|
|
;; repeat from 0 (as a maybe rule)
|
|
(recur #'(rule NAME (maybe (repeat 1 MAYBE-MAX SUB-PAT))) #f)]
|
|
|
|
[(repeat MIN #f SUB-PAT)
|
|
;; indefinite repeat
|
|
(begin
|
|
(define-values (inferred-rules new-sub-pats)
|
|
(lift-nonprimitive-pattern #'SUB-PAT))
|
|
(with-syntax ([(SUB-PAT ...) new-sub-pats]
|
|
[MIN-REPEAT-SUB-PATS (apply append (make-list (syntax-e #'MIN) new-sub-pats))])
|
|
(cons #`(HEAD ORIGIN NAME
|
|
[(inferred-id NAME repeat) SUB-PAT ...]
|
|
MIN-REPEAT-SUB-PATS)
|
|
inferred-rules)))]
|
|
|
|
[(repeat MIN MAX SUB-PAT)
|
|
;; finite repeat
|
|
(begin
|
|
(define min (syntax-e #'MIN))
|
|
(define max (syntax-e #'MAX))
|
|
(unless (<= min max)
|
|
(raise-syntax-error #f (format "minimum repeat count cannot be larger than maximum, got {~a,~a}" min max) a-rule))
|
|
;; has to keep the same rule NAME to work correctly
|
|
(define new-rule-stx
|
|
(if (= min max)
|
|
(with-syntax ([MIN-SUBPATS (make-list min #'SUB-PAT)])
|
|
#'(rule NAME (seq . MIN-SUBPATS)))
|
|
(with-syntax ([REPEATS-REMAINING (- max min)]) ; REPEATS-REMAINING is a positive integer
|
|
#'(rule NAME (seq (repeat MIN MIN SUB-PAT) (repeat 0 REPEATS-REMAINING SUB-PAT))))))
|
|
(recur new-rule-stx #f))]
|
|
|
|
[(maybe SUB-PAT)
|
|
(begin
|
|
(define-values (inferred-rules new-sub-pats)
|
|
(lift-nonprimitive-pattern #'SUB-PAT))
|
|
(with-syntax ([(SUB-PAT ...) new-sub-pats])
|
|
(cons #'(HEAD ORIGIN NAME
|
|
[SUB-PAT ...]
|
|
[])
|
|
inferred-rules)))]
|
|
|
|
[(seq SUB-PAT ...)
|
|
(begin
|
|
(define-values (inferred-rules new-sub-pats)
|
|
(lift-nonprimitive-patterns (syntax->list #'(SUB-PAT ...))))
|
|
(with-syntax ([(SUB-PAT ...) new-sub-pats])
|
|
(cons #'(HEAD ORIGIN NAME [SUB-PAT ...])
|
|
inferred-rules)))])]))))
|
|
|
|
|
|
;; Given a pattern, return a key appropriate for a hash.
|
|
;;
|
|
;; In the `ragg` days this used `syntax->datum` only.
|
|
;; The problem is that with cuts & splices in the mix, it creates ambiguity:
|
|
;; e.g., the pattern (/"," foo)* and ("," foo)* differ only in the 'hide syntax property
|
|
;; so `syntax->datum` does not capture their differences.
|
|
;; That means they produced the same hash key,
|
|
;; which meant they produced the same inferred pattern. Which is wrong.
|
|
;; So we adjust the key to take account of the 'hide property
|
|
;; by "lifting" it into the datum with cons.
|
|
;; Then the pattern-inference process treats them separately.
|
|
(define (pattern->hash-key a-pat)
|
|
(let loop ([x a-pat])
|
|
(let ([maybe-stx-list (syntax->list x)])
|
|
(if maybe-stx-list
|
|
(cons (syntax-property x 'hide) (map loop maybe-stx-list))
|
|
(syntax->datum x)))))
|
|
|
|
|
|
;; Returns true if the pattern looks primitive
|
|
(define (primitive-pattern? a-pat)
|
|
(syntax-case a-pat (id lit token choice repeat maybe seq)
|
|
[(id val)
|
|
#t]
|
|
[(lit val)
|
|
#t]
|
|
[(token val)
|
|
#t]
|
|
[(choice sub-pat ...)
|
|
#f]
|
|
[(repeat min max val)
|
|
#f]
|
|
[(maybe sub-pat)
|
|
#f]
|
|
[(seq sub-pat ...)
|
|
(andmap primitive-pattern? (syntax->list #'(sub-pat ...)))]))
|
|
|
|
|
|
;; Given a primitive pattern (id, lit, token, and seqs only containing
|
|
;; primitive patterns), returns a linear sequence of just id, lits,
|
|
;; and tokens.
|
|
(define (linearize-primitive-pattern a-pat)
|
|
(define (traverse a-pat acc)
|
|
(syntax-case a-pat (id inferred-id lit token seq)
|
|
[(id val)
|
|
(cons a-pat acc)]
|
|
[(inferred-id val reason)
|
|
(cons a-pat acc)]
|
|
[(lit val)
|
|
(cons a-pat acc)]
|
|
[(token val)
|
|
(cons a-pat acc)]
|
|
[(seq vals ...)
|
|
(foldl traverse acc (syntax->list #'(vals ...)))]))
|
|
(reverse (traverse a-pat '())))
|
|
|
|
|
|
|
|
(define-syntax (prim-rule stx)
|
|
(raise-syntax-error #f "internal error: should not be macro expanded" stx))
|
|
|
|
(define-syntax (inferred-prim-rule stx)
|
|
(raise-syntax-error #f "internal error: should not be macro expanded" stx))
|
|
|
|
(define-syntax (inferred-id stx)
|
|
(raise-syntax-error #f "internal error: should not be macro expanded" stx))
|