(module srfi-105.extra ($nfx$
                        $bracket-apply$
                        **
                        %
                        >>
                        <<
                        ^
                        ior
                        &
                        ~
                        !)
  (import scheme
          srfi-105
          chicken.base
          chicken.syntax
          chicken.bitwise
          chicken.keyword
          srfi-1
          (except srfi-123 ~))

  (import-for-syntax matchable srfi-1 chicken.keyword)

  (define $bracket-apply$ ref*)

  (define-syntax **
    (syntax-rules ()
      ((_ a b)
       (expt a b))
      ((_ a rest ...)
       (expt a (** rest ...)))))

  (define-syntax %
    (syntax-rules ()
      ((_ a b)
       (modulo a b))
      ((_ a b rest ...)
       (% (modulo a b) rest ...))))

  (define-syntax <<
    (syntax-rules ()
      ((_ a b)
       (arithmetic-shift a b))
      ((_ a b rest ...)
       (<< (arithmetic-shift a b) rest ...))))

  (define-syntax >>
    (syntax-rules ()
      ((_ a b)
       (arithmetic-shift a (- b)))
      ((_ a b rest ...)
       (>> (arithmetic-shift a (- b)) rest ...))))

  (define-syntax ^
    (syntax-rules ()
      ((_ a b)
       (bitwise-xor a b))
      ((_ a b rest ...)
       (^ (bitwise-xor a b) rest ...))))

  (define-syntax ior
    (syntax-rules ()
      ((_ a b)
       (bitwise-ior a b))
      ((_ a b rest ...)
       (ior (bitwise-ior a b) rest ...))))

  (define-syntax &
    (syntax-rules ()
      ((_ a b)
       (bitwise-and a b))
      ((_ a b rest ...)
       (& (bitwise-and a b) rest ...))))

  (define ~ bitwise-not)
  (define ! not)

  (define-for-syntax mixed-operator-precedence
    (make-parameter
     '(((#:right expt) (#:right **))
       (* / modulo % quotient remainder
          fx* fx/ fxmod fxrem
          fp* fp/)
       (+ - fx+ fx- fp+ fp-)
       (arithmetic-shift << >> fxshl fxshr)
       (bitwise-and & fxand)
       (bitwise-xor ^ fxxor)
       (bitwise-ior ior fxior)
       (#:other)
       (#:comparison < <= > >= =
                     fx< fx<= fx> fx>= fx=
                     fp< fp<= fp> fp>= fp=)
       (and)
       (or))
     (lambda (l)
       (assert (member '(#:other) l)
               'mixed-operator-precedence
               "precedence parameter should at least contain the group (#:other)"
               l)
       l)))

  ;; The following commented procedure was here to handle stuff like python's
  ;; +x, -x, ~x but screw that, it's a whole can of worms - use neoteric syntax
  ;; for these. reference:
  ;; https://docs.python.org/3/reference/expressions.html#operator-precedence

  ;; Ok fine, the problem is this: how do we detect these?

  ;; I was doing e.g. {a + - b} - just check if the symbol at the - position is
  ;; in the single: group and if the symbol at the + position is a symbol,
  ;; right? nope, what if we actually want to do some-variable - b ? We can't
  ;; just check for no spaces between the singlet operator and the operand
  ;; (e.g. -b), since scheme symbols include our operators as valid characters.
  ;; Sure, we can restrict the symbol? check to 'if it's one of our known
  ;; operators' but then what if you want to use another arbitary command like
  ;; a my-fn - b ? I think the fact that we support arbitrary commands might be
  ;; the problem here. We could maybe do some more crazy list length and
  ;; paired/even/odd checking or whatever, but is that worth it? no. Would it
  ;; even eliminate the ambiguity? probably not. Just use neoteric expressions

  ;; (define-for-syntax (group-single ops lst)
  ;;   (let loop ((lst lst))
  ;;     (cond ((or (null? lst)
  ;;                (null? (cdr lst)))
  ;;            lst)
  ;;           ((and (memv (cadr lst) ops)
  ;;                 (symbol? (car lst)))
  ;;            (let ((lst (cons (car lst)
  ;;                             (cons (list (cadr lst) (caddr lst))
  ;;                                   (cdddr lst)))))
  ;;              (loop lst)))
  ;;           (else (cons (car lst) (loop (cdr lst)))))))

  (define-syntax $nfx$
    (er-macro-transformer
     (lambda (e r c)
       (define all-operators (map
                              (lambda (op)
                                (if (and (pair? op)
                                         (eqv? (car op) #:right))
                                    (cadr op)
                                    op))
                              (filter (complement keyword?)
                                      (flatten (mixed-operator-precedence)))))


       (define (group-assoc ops lst)
         (define (rightop-group-head op lst)
           (define (is-op? c) (eqv? c op))
           (receive (head tail)
               (let loop ((lst lst))
                 (match lst
                   ((a (? is-op? operator) b . (and rest
                                                    (or ()
                                                        ((? (complement is-op?) _) . _))))
                    (values
                     (list operator a b)
                     rest))
                   ((a (? is-op? operator)  b . rest)
                    (receive (head tail) (loop (cons b rest))
                      (values (cons*
                               operator
                               a
                               (list head))
                              tail)))))
             (cons head tail)))
         (define (left-op? c) (memv c ops))
         (define (right-op? c) (member `(#:right ,c) ops))
         (let loop ((lst lst))
           (match lst
             ((or () (_)) lst)
             ((a (? left-op? operator)  b . rest)
              (let ((lst (cons (list operator a b) rest)))
                (loop lst)))
             ((a (? right-op? operator) b . rest)
              (loop (rightop-group-head operator lst)))
             (else (cons* (car lst) (cadr lst) (loop (cddr lst)))))))

       (define (group-other lst)
         (define (unknown-operator? c) (not (memv c all-operators)))
         (let loop ((lst lst))
           (match lst
             ((or () (_)) lst)
             ((a (? unknown-operator? operator) b . rest)
              (let ((lst (cons (list operator a b) rest)))
                (loop lst)))
             (else (cons* (car lst) (cadr lst) (loop (cddr lst)))))))

       (define (group-comparison ops lst)
         (define (ops-member? c) (memv c ops))
         (define (comparison-group-head lst)
           (receive (head tail)
               (let loop ((lst lst)
                          (chain #f))
                 (match lst
                   ((a (? ops-member? operator) b . (and rest
                                                         (or ()
                                                             ((? (complement ops-member?) _) . _))))
                    (values
                     ((if chain identity list) (list operator a b))
                     rest))
                   ((a (? ops-member? operator)  b . rest)
                    (receive (head tail) (loop (cons b rest) #t)
                      (values (cons
                               (list operator a b)
                               (list head))
                              tail)))))
             (cons (cons 'and head) tail)))
         (let loop ((lst lst))
           (match lst
             ((or () (_)) lst)
             ((a (? ops-member? operator) b . rest)
              (loop (comparison-group-head lst)))
             (else (cons* (car lst) (cadr lst) (loop (cddr lst)))))))

       (if (not (even? (length e)))
           (error "mixed infix expressions require an odd number of parameters")
           (let ((result (foldl (lambda (lst ops)
                                  (let ((maybe-keyword (car ops)))
                                    (case maybe-keyword
                                      ((#:other) (group-other lst))
                                      ((#:comparison) (group-comparison (cdr ops) lst))
                                      (else (group-assoc ops lst)))))
                                (cdr e)
                                (mixed-operator-precedence))))
             (if (not (null? (cdr result)))
                 (error "Syntax error or unhandled operator resulted in bad expansion" result)
                 (car result))))))))