pattern-matcher.rkt

#lang racket/base

(require racket/contract racket/list racket/match racket/hash)

;; dots ::= ... (literal dots)
;;
;; pattern ::= symbol | boolean | number | string | ,identifier | pattern-list
;; pattern-list ::= () | (pattern . pattern-list)
;;                     | (pattern dots . pattern-list)
;;
;; variable ::= identifier | (variable dots)
;;
;; matches ::= (hash/c variable any/c)
;;   The nested level of the value must match the nested level of the variable

(define pattern/c
  (recursive-contract
   (or/c (and/c (not/c '...) symbol?) boolean? number? string?
         (list/c 'unquote symbol?)
         pattern-list/c)
   #:chaperone))
(define pattern-list/c
  (recursive-contract
   (or/c '()
         (cons/c pattern/c (cons/c '... pattern-list/c))
         (cons/c pattern/c pattern-list/c))
   #:chaperone))

(define (find-variables pattern)
  (match pattern
    [(list 'unquote '_) '()]
    [(list 'unquote (? symbol? var)) (list var)]
    [(list* sub-pattern '... rest-patterns)
     (append (for/list ([var (in-list (find-variables sub-pattern))])
               `(,var ...))
             (find-variables rest-patterns))]
    [(cons sub-pattern rest-patterns)
     (append (find-variables sub-pattern)
             (find-variables rest-patterns))]
    [else '()]))





(struct exn:fail:no-match exn:fail () #:transparent)

;; run-pattern : pattern expression -> matches
(define (run-pattern pattern value)
  (define (guard succeeded?)
    (unless succeeded?
      (raise (exn:fail:no-match
              (format "pattern match failed\n pattern: ~a\n value: ~a"
                      pattern
                      value)
              (current-continuation-marks)))))
  (match pattern
    [(list 'unquote '_)              (hash)]
    [(list 'unquote (? symbol? var)) (hash var value)]
    [(list* sub-pattern '... rest-patterns)
     (guard (list? value))
     (define vars (find-variables sub-pattern))
     (define sub-matches
       (for*/list ([current-value (in-list value)]
                   [sub-match (in-value
                               (with-handlers ([exn:fail:no-match? (λ (exn) #f)])
                                 (run-pattern sub-pattern current-value)))]
                   #:break (not sub-match))
         sub-match))
     (define rest-values
       (drop value (length sub-matches)))
     (define matched-variables
       (for/hash ([var (in-list vars)])
         (values `(,var ...)
                 (for/list ([sub-match (in-list sub-matches)])
                   (hash-ref sub-match var)))))
     (hash-union
      matched-variables
      (run-pattern rest-patterns rest-values))]
    [(cons sub-pattern rest-patterns)
     (guard (pair? value))
     (hash-union
      (run-pattern sub-pattern (car value))
      (run-pattern rest-patterns (cdr value)))]
    [else
     (guard (equal? pattern value))
     (hash)]))





(struct exn:fail:template exn:fail () #:transparent)

;; run-template : matches template -> expression
;;   template = pattern without `,_'
(define (run-template matches template)
  (match template
    [(list 'unquote (? symbol? var))
     (hash-ref matches var)]
    [(list* sub-template '... rest-templates)
     (define vars (find-variables sub-template))
     (define vars-to-open
       (for/list ([var (in-list vars)]
                  #:when (hash-has-key? matches `(,var ...)))
         var))
     (unless (not (null? vars-to-open))
       (raise (exn:fail:template
               (format (string-append "ellipses do not refer to any variable\n"
                                      " template: ~a\n"
                                      " variables: ~a")
                       template
                       matches)
               (current-continuation-marks))))
     (define repeat-count (length (hash-ref matches `(,(car vars-to-open) ...))))
     (unless (for/and ([var-to-open (in-list vars-to-open)])
               (= repeat-count (length (hash-ref matches `(,var-to-open ...)))))
       (raise (exn:fail:template
               (format (string-append "matched variables are not of the same length\n"
                                      " template: ~a\n"
                                      " matched variables: ~a\n"
                                      " all variables: ~a")
                       template
                       (for/hash ([var-to-open (in-list vars-to-open)])
                         (values `(,var-to-open ...)
                                 (hash-ref matches `(,var-to-open ...))))
                       matches)
               (current-continuation-marks))))
     (define sub-exprs
       (for/list ([i (in-range repeat-count)])
         (define opened-sub-match
           (for/hash ([var-to-open (in-list vars-to-open)])
             (values var-to-open (list-ref (hash-ref matches `(,var-to-open ...)) i))))
         (run-template (hash-union matches opened-sub-match)
                       sub-template)))
     (append sub-exprs (run-template matches rest-templates))]
    [(cons sub-template rest-templates)
     (cons (run-template matches sub-template)
           (run-template matches rest-templates))]
    [else
     template]))

(module+ test
  (require rackunit)

  (check-equal? (run-pattern
                 '(let ([,var ,rhs] ...) ,body)
                 '(let ([x 5]
                        [y 8]
                        [z 9])
                    (+ 1 2)))
                (hash '(var ...) '(x y z)
                      '(rhs ...) '(5 8 9)
                      'body '(+ 1 2)))

  (check-equal? (run-pattern
                 '(let-values ([(,var ...) ,rhs] ...) ,body)
                 '(let-values ([(base name dir?) (split-path "./s/folder/file.txt")]
                               [(x) 'tt])
                    name))
                (hash '((var ...) ...) '((base name dir?) (x))
                      '(rhs ...) '((split-path "./s/folder/file.txt") 'tt)
                      'body 'name))

  (check-equal? (run-template
                 (hash '((var ...) ...) '((base name dir?) (x))
                       '(rhs ...) '((split-path "./s/folder/file.txt") 'tt)
                       'body 'name)
                 '(let-values ([(,var ...) ,rhs] ...) ,body))
                '(let-values ([(base name dir?) (split-path "./s/folder/file.txt")]
                              [(x) 'tt])
                   name))

  (check-equal? (run-template
                 (hash '(i ...) '(1 2 3)
                       '(j ...) '(a b c))
                 '((,i ,j ...) ...))
                '((1 a b c)
                  (2 a b c)
                  (3 a b c)))

  (check-equal? (run-template
                 (hash '((n ...) ...) '((1 2 3) (4 5 6) (7 8 9))
                       '(s ...) '(a b c))
                 '(X (Y (Z ,n ,s) ...) ...))
                '(X (Y (Z 1 a) (Z 2 b) (Z 3 c))
                    (Y (Z 4 a) (Z 5 b) (Z 6 c))
                    (Y (Z 7 a) (Z 8 b) (Z 9 c))))
  )

(module+ alternative-implementation
  (define (make-constant-hash keys default-value)
    (for/hash ([key (in-list keys)])
      (values key default-value)))

  (define (hash-map/hash h f)
    (for/hash ([(key value) (in-hash h)])
      (f key value)))

  (define (run-pattern/internal-state pattern value)
    (define (guard succeeded?)
      (unless succeeded?
        (raise (exn:fail:no-match (format "pattern match failed\n pattern: ~a\n value: ~a"
                                          pattern
                                          value)
                                  (current-continuation-marks)))))
    (match pattern
      [(list 'unquote '_)              (hash)]
      [(list 'unquote (? symbol? var)) (hash var value)]
      [(list* sub-pattern '... rest-patterns)
       (guard (list? value))
       (define vars (find-variables sub-pattern))
       (define matched-variables (make-constant-hash vars '()))
       (define rest-values value)
       (with-handlers ([exn:fail:no-match? void])
         (for ([current-value (in-list value)])
           (define new-matches
             (run-pattern/internal-state sub-pattern current-value))
           (set! matched-variables (hash-union new-matches
                                               matched-variables
                                               #:combine cons))
           (set! rest-values (cdr rest-values))))
       (hash-union
        (hash-map/hash matched-variables (λ (k v) (values `(,k ...) (reverse v))))
        (run-pattern/internal-state rest-patterns rest-values))]
      [(cons sub-pattern rest-patterns)
       (guard (pair? value))
       (hash-union
        (run-pattern/internal-state sub-pattern (car value))
        (run-pattern/internal-state rest-patterns (cdr value)))]
      [else
       (guard (equal? pattern value))
       (hash)]))
  )