#lang racket

(require (for-syntax syntax/parse
                     syntax/boundmap
                     racket))

(provide (except-out (all-from-out racket) #%app)
         (rename-out [infix #%app])
         infix-set!
         $)

(define-for-syntax infix-hash (make-free-identifier-mapping))

(define-syntax-rule (infix-set! (name p assoc) ...)
  (begin-for-syntax (free-identifier-mapping-put! infix-hash
                                                  #`name
                                                  (cons (syntax->datum #`p)
                                                        (syntax->datum #`assoc))) ...))


(define-for-syntax (get-id-props id)
  (free-identifier-mapping-get infix-hash id (λ () #f)))


(define-syntax (infix stx)
  (define-syntax-class op
    (pattern x:id
             #:when (get-id-props #'x)))

  (define-splicing-syntax-class l
    (pattern (~seq arg op:op)))

  (define-splicing-syntax-class r
    (pattern (~seq l:l r:r)
             #:do [(define new-op (attribute l.op))
                   (define new-op-prior (car (get-id-props (attribute l.op))))
                   (define new-arg (attribute l.arg))
                   (define comparator
                     (case (cdr (get-id-props (attribute l.op)))
                       [(left) >=]
                       [(right) >]))
                   (define-values (ops args)
                     (let loop ([ops (attribute r.op-stack)]
                                [args (attribute r.arg-stack)])
                       (cond
                        [(null? ops) (values (list (cons new-op new-op-prior)) (cons new-arg args))]
                        [(comparator new-op-prior (cdar ops))
                         (values (cons (cons new-op new-op-prior) ops) (cons new-arg args))]
                        [else (loop (cdr ops) (cons #`(#,(caar ops) #,(first args) #,(second args)) (cddr args)))])))]
             #:attr op-stack ops
             #:attr arg-stack args)
    (pattern x
             #:attr op-stack `()
             #:attr arg-stack (list #`x)))

  (syntax-parse stx
    [(_ infix-expr:r)
     (let loop ([ops (map car (attribute infix-expr.op-stack))]
                [args (attribute infix-expr.arg-stack)])
       (if (null? ops)
           (car args)
           (loop (cdr ops) (cons #`(#,(car ops) #,(first args) #,(second args)) (cddr args)))))]
    [(_ args ...) #`(args ...)]))

(infix-set! (+ 5 left)
            (- 5 left)
            (* 6 left)
            (/ 6 left)
            ($ 3 right))

(define ($ f x) (f x))