brag/codegen/flatten.rkt

#lang racket/base
(require yaragg/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))