#lang racket/base

(provide (struct-out discard)
         (struct-out capture)

         (for-syntax analyse-pattern
                     instantiate-pattern->pattern
                     instantiate-pattern->value
                     desc->key
                     desc->skeleton-proj
                     desc->skeleton-stx
                     desc->capture-proj
                     desc->capture-names
                     desc->assertion-stx)

         (all-from-out "pattern-expander.rkt"))

(require (for-syntax racket/base))
(require (for-syntax racket/match))
(require (for-syntax racket/struct-info))
(require (for-syntax syntax/stx))
(require "pattern-expander.rkt")

(struct discard () #:prefab)
(struct capture (detail) #:prefab)

;;---------------------------------------------------------------------------
;; ## Analysing patterns
;;
;; Patterns generate several pieces, which work together to form
;; routing tables:
;;
;;  - the *assertion* allows observers of observers to function;
;;  - the `Skeleton` classifies the shape of the pattern;
;;  - two `SkProj`s select constant and variable pieces from a pattern, respectively; and
;;  - a `SkKey` specifies constant pieces of a pattern, matched against one of the `SkProj`s.
;;
;; The other `SkProj` generates a second `SkKey` which is used as the
;; input to a handler function.

(define-for-syntax orig-insp
  (variable-reference->module-declaration-inspector (#%variable-reference)))

(begin-for-syntax
  (define (dollar-id? stx)
    (and (identifier? stx)
         (char=? (string-ref (symbol->string (syntax-e stx)) 0) #\$)))

  (define (undollar stx)
    (and (dollar-id? stx)
         (datum->syntax stx (string->symbol (substring (symbol->string (syntax-e stx)) 1)))))

  (define (discard-id? stx)
    (and (identifier? stx)
         (free-identifier=? #'_ stx)))

  (define (id-value stx)
    (and (identifier? stx)
         (syntax-local-value stx (lambda () #f))))

  (define (list-id? stx)
    (and (identifier? stx)
         (free-identifier=? #'list stx)))

  (define (vector-id? stx)
    (and (identifier? stx)
         (free-identifier=? #'vector stx)))

  (define (analyse-pattern stx)
    (define disarmed-stx (syntax-disarm stx orig-insp))
    (syntax-case disarmed-stx ($ quasiquote unquote quote)
      [(expander args ...)
       (pattern-expander-id? #'expander)
       (pattern-expander-transform disarmed-stx
                                   (lambda (result)
                                     (analyse-pattern (syntax-rearm result stx))))]

      ;; Extremely limited support for quasiquoting and quoting
      [(quasiquote (unquote p)) (analyse-pattern #'p)]
      [(quasiquote (p ...)) (analyse-pattern #'(list (quasiquote p) ...))]
      [(quasiquote p) (list 'atom stx)]
      [(quote p) (list 'atom stx)]

      [(ctor piece ...)
       (struct-info? (id-value #'ctor))
       (list* 'compound
              (extract-struct-info (id-value #'ctor))
              (stx-map analyse-pattern #'(piece ...)))]
      [(list piece ...)
       (list-id? #'list)
       (list* 'compound
              'list
              (stx-map analyse-pattern #'(piece ...)))]
      [(vector piece ...)
       (vector-id? #'vector)
       (list* 'compound
              'vector
              (stx-map analyse-pattern #'(piece ...)))]
      [id
       (dollar-id? #'id)
       (list 'capture (undollar #'id) (list 'discard))]
      [($ id p)
       (list 'capture #'id (analyse-pattern #'p))]
      [id
       (discard-id? #'id)
       (list 'discard)]
      [_
       (list 'atom stx)]))

  (define (instantiate-pattern->pattern stx)
    (define disarmed-stx (syntax-disarm stx orig-insp))
    (syntax-case disarmed-stx ($ quasiquote unquote quote)
      [(expander args ...)
       (pattern-expander-id? #'expander)
       (pattern-expander-transform disarmed-stx
                                   (lambda (result)
                                     (instantiate-pattern->pattern (syntax-rearm result stx))))]

      ;; Extremely limited support for quasiquoting and quoting
      [(quasiquote (unquote p)) (instantiate-pattern->pattern #'p)]
      [(quasiquote (p ...)) (instantiate-pattern->pattern #'(list (quasiquote p) ...))]
      [(quasiquote p) stx]
      [(quote p) stx]

      [(ctor piece ...)
       (struct-info? (id-value #'ctor))
       (quasisyntax/loc stx (ctor #,@(stx-map instantiate-pattern->pattern #'(piece ...))))]
      [(list piece ...)
       (list-id? #'list)
       (quasisyntax/loc stx (list #,@(stx-map instantiate-pattern->pattern #'(piece ...))))]
      [(vector piece ...)
       (vector-id? #'vector)
       (quasisyntax/loc stx (vector #,@(stx-map instantiate-pattern->pattern #'(piece ...))))]
      [id
       (dollar-id? #'id)
       (undollar #'id)]
      [($ id p)
       #'id]
      [id
       (discard-id? #'id)
       #'id]
      [other
       #'other]))

  (define (instantiate-pattern->value stx)
    (define disarmed-stx (syntax-disarm stx orig-insp))
    (syntax-case disarmed-stx ($ quasiquote unquote quote)
      [(expander args ...)
       (pattern-expander-id? #'expander)
       (pattern-expander-transform disarmed-stx
                                   (lambda (result)
                                     (instantiate-pattern->value (syntax-rearm result stx))))]

      ;; Extremely limited support for quasiquoting and quoting
      [(quasiquote (unquote p)) (instantiate-pattern->value #'p)]
      [(quasiquote (p ...)) (instantiate-pattern->value #'(list (quasiquote p) ...))]
      [(quasiquote p) stx]
      [(quote p) stx]

      [(ctor piece ...)
       (struct-info? (id-value #'ctor))
       (quasisyntax/loc stx (ctor #,@(stx-map instantiate-pattern->value #'(piece ...))))]
      [(list piece ...)
       (list-id? #'list)
       (quasisyntax/loc stx (list #,@(stx-map instantiate-pattern->value #'(piece ...))))]
      [(vector piece ...)
       (vector-id? #'vector)
       (quasisyntax/loc stx (vector #,@(stx-map instantiate-pattern->value #'(piece ...))))]
      [id
       (dollar-id? #'id)
       (undollar #'id)]
      [($ id p)
       #'id]
      [id
       (discard-id? #'id)
       #'(discard)]
      [other
       #'other])))

;;---------------------------------------------------------------------------

(begin-for-syntax
  (define (select-pattern-leaves desc capture-fn atom-fn)
    (define (walk-node key-rev desc)
      (match desc
        [`(compound ,_ ,pieces ...) (walk-edge 0 key-rev pieces)]
        [`(capture ,name-stx ,p) (append (capture-fn key-rev name-stx) (walk-node key-rev p))]
        [`(discard) (list)]
        [`(atom ,v) (atom-fn key-rev v)]))
    (define (walk-edge index key-rev pieces)
      (match pieces
        ['() '()]
        [(cons p pieces) (append (walk-node (cons index key-rev) p)
                                 (walk-edge (+ index 1) key-rev pieces))]))
    (walk-node '() desc))

  (define (desc->key desc)
    (select-pattern-leaves desc
                           (lambda (key-rev name-stx) (list))
                           (lambda (key-rev atom) (list atom))))

  (define (desc->skeleton-proj desc)
    (select-pattern-leaves desc
                           (lambda (key-rev name-stx) (list))
                           (lambda (key-rev atom) (list (reverse key-rev)))))

  (define (desc->skeleton-stx desc)
    (match desc
      [`(compound list ,pieces ...)
       #`(list 'list #,@(map desc->skeleton-stx pieces))]
      [`(compound vector ,pieces ...)
       #`(list 'vector #,@(map desc->skeleton-stx pieces))]
      [`(compound (,struct-type ,_ctor ,_pred ,_getters ,_setters ,_super) ,pieces ...)
       #`(list #,struct-type #,@(map desc->skeleton-stx pieces))]
      [`(capture ,_ ,p) (desc->skeleton-stx p)]
      [`(discard) #'#f]
      [`(atom ,atom-stx) #'#f]))

  (define (desc->capture-proj desc)
    (select-pattern-leaves desc
                           (lambda (key-rev name-stx) (list (reverse key-rev)))
                           (lambda (key-rev atom) (list))))

  (define (desc->capture-names desc)
    (select-pattern-leaves desc
                           (lambda (key-rev name-stx) (list name-stx))
                           (lambda (key-rev atom) (list))))

  (define (desc->assertion-stx desc)
    (match desc
      [`(compound list ,pieces ...)
       #`(list #,@(map desc->assertion-stx pieces))]
      [`(compound vector ,pieces ...)
       #`(vector #,@(map desc->assertion-stx pieces))]
      [`(compound (,_struct-type ,ctor ,_pred ,_getters ,_setters ,_super) ,pieces ...)
       #`(#,ctor #,@(map desc->assertion-stx pieces))]
      [`(capture ,_ ,p) #`(capture #,(desc->assertion-stx p))]
      [`(discard) #'(discard)]
      [`(atom ,v) v]))
  )