#lang racket
(require (for-syntax racket/base)
         (only-in "formal.rkt" formal?))


(provide replace
         replace-all /.
         define/.)


;;====================================================
;; error messages
;;====================================================

(define-for-syntax error-source (make-parameter #f))

(define-for-syntax (error: message stx)
  (raise-syntax-error (error-source) message (map syntax->datum stx)))

;;================================================================================
;;    rewrite-once form
;;================================================================================

(define-for-syntax (conditional? l)
  (and (pair? (syntax-e (cadr l)))
       (eq? '? (syntax-e (car (syntax-e (cadr l)))))))

(define-for-syntax (=>? l)
  (and (pair? (syntax-e (cadr l)))
       (eq? '=> (syntax-e (car (syntax-e (cadr l)))))))


;; parsing the reduction sequence
;; p __1 --> r  ==>  [(list p) r]
(define-for-syntax (parse-RS-rules stx)
  (parameterize ([error-source 'replace])
    (let loop ([l (syntax->list stx)])
      (cond
        [(null? l) '()]
        [(eq? (syntax-e (car l)) '-->) (error: "Missing pattern" l)]
        [(null? (cdr l)) (error: "Missing reduction rule after pattern" l)]
        [else 
         (let read-patterns ([l l] [res '()])
           (cond
             [(null? (cdr l)) (error: "Missing reduction rule" res)]
             [else 
              (case (syntax-e (car l))
                ['--> (cond
                        [(conditional? l)
                         (append (list (list (cons 'list (reverse res)) 
                                             `(=> fail)
                                             `(if ,(cadr (syntax-e (cadr l))) 
                                                ,(caddr l) 
                                                (fail))))
                                 (loop (cdddr l)))]
                        [(=>? l) 
                         (append (list (list (cons 'list (reverse res)) 
                                             (cadr l)
                                             (caddr l)))
                                 (loop (cdddr l)))]
                        [else (append (list (list (cons 'list (reverse res)) 
                                                  (cadr l)))
                                      (loop (cddr l)))])]
                ['-->. (error: "Terminal reduction -->. only allowed inside rewrite form."
                               (list (car res) (car l) (cadr l)))]
                [else (read-patterns (cdr l) (cons (car l) res))])]))]))))

;: Produces a reduction system which is applied once.
(define-syntax (replace stx) ;: red ... -> procedure?
  (syntax-case stx ()
    [(_ rules ...) 
     (with-syntax  ([(p ...) (parse-RS-rules #'(rules ...))])
       #'(procedure-rename
          (match-lambda* 
            p ... 
            [(list any) any] 
            [any any])
          'replace))]))

;; The reductions are listable.
(define-syntax (replace-all stx) ;: red ... -> procedure?
  (syntax-case stx ()
    [(_ rules ...) 
     (with-syntax  ([(p ...) (parse-RS-rules #'(rules ...))])
       #'(letrec 
              ([f (match-lambda* 
                    p ... 
                    [(list (? formal? any)) (map f any)]
                    [(list (? list? any)) (map f any)] 
                    [(list any) any] 
                    [any any])])
            (procedure-rename f 'replace-all)))]))

;;================================================================================
;; Aliases
;;================================================================================
;: Binds symbol name with reduction system so that it could be used withen reduction rules.
;: symbol? rules ... -> procudure?
(define-syntax-rule (define/. name rules ...) 
  (define name (replace-all rules ...)))

(define-syntax-rule (/. rules ...) (replace-all rules ...))