infixing.clj

(defn infixing-infix [rules infix-rule [a b & code]] (cond
  (nil? b)         `(~a)
  (nil? (rules b)) (cond
    (seq? a) (infixing-infix rules infix-rule `((~@a ~b) ~@code))
    :else    (infixing-infix rules infix-rule `((~a ~b) ~@code)))
  :else            (let [ b-rule (rules b) ] (cond
    (< (b-rule :priority) (infix-rule :priority))  `(~a (~b ~@code))
    (> (b-rule :priority) (infix-rule :priority))  (infixing-infix rules infix-rule `((~b ~a) ~@code))
    (= :left (b-rule :recur) (infix-rule :recur))  `(~a (~b ~@code))
    (= :right (b-rule :recur) (infix-rule :recur)) (infixing-infix rules infix-rule `((~b ~a) ~@code))
    :else                                          'undefined))))

(declare infixing infixing-recur)

(defn infixing-entry [rules [left curr & code]] (cond
  (nil? curr)         left
  (nil? (rules curr)) (cond
    (seq? left) (infixing-entry rules `((~@left ~(infixing-recur rules curr)) ~@code))
    :else       (infixing-entry rules `((~left ~(infixing-recur rules curr)) ~@code)))
  :else               (let [ [right code] (infixing-infix rules (rules curr) code) ] (cond
    (empty? code)       `(~(infixing-recur rules curr) ~left ~(infixing-recur rules right))
    :else               (infixing-entry rules `((~(infixing-recur rules curr) ~left ~(infixing-recur rules right)) ~@code))))))

(defn infixing-recur [rules code] (cond
  (seq? code) (let [[left curr & code] code] (cond
    (seq? curr) (infixing rules `(~left ~(infixing-recur rules curr) ~@code))
    :else       (infixing rules `(~left ~curr ~@code))))
  :else       code))

(defn infixing [rules [left curr & code]]
  (infixing-entry rules `(~(infixing-recur rules left) ~curr ~@code)))

(println (infixing {} '(f x y)))
; => (f x y)
(println (infixing {'* {:priority 5 :recur :left} '+ {:priority 4 :recur :left}} '(x + y * z + hh)))
; => (+ (+ x (* y z)) hh)
(println (infixing {'* {:priority 5 :recur :left} '+ {:priority 4 :recur :left}} '(x + y + z)))
; => (+ (+ x y) z)
(println (infixing {'* {:priority 5 :recur :left} '+ {:priority 4 :recur :left}} '(x * y + z * hh)))
; => (+ (* x y) (* z hh))
(println (infixing {'& {:priority 5 :recur :right} '| {:priority 4 :recur :right}} '(x & y & z)))
; => (& x (& y z))

(defn infix [priority symbol & symbols]
  (let [symbols (cons symbol symbols)]
    (reduce merge (map (fn [s] {s {:priority priority :recur nil}}) symbols))))

(defn infixl [priority symbol & symbols]
  (let [symbols (cons symbol symbols)]
    (reduce merge (map (fn [s] {s {:priority priority :recur :left}}) symbols))))

(defn infixr [priority symbol & symbols]
  (let [symbols (cons symbol symbols)]
    (reduce merge (map (fn [s] {s {:priority priority :recur :right}}) symbols))))

(defn rules [& rules]
  (reduce merge rules))

(println  (infixing (infixr 0 '$) '(f $ g x)))
; => ($ f (g x))

(defmacro infixing-simple [code]
  (infixing (rules (infixl 7 '*)
                   (infixl 6 '+)
                   (infixl 6 '-))
            code))
(def x (infixing-simple (1 + 2 * 3 + 4)))
(println x) ; => 11
(def y (infixing-simple ((1 + 2) * (3 + 4))))
(println y) ; => 21





(defmacro infixing-plang [code]
  (infixing (rules (infix 4 '=)
                   (infixl 6 '+ '-)
                   (infixl 7 '*)
                   (infixr 3 'and)
                   (infixr 2 'or))
    code))

(defmacro defplang [a b code]
  `(defn ~a ~b (infixing-plang ~code)))

(defplang add [x y] (x + y))

(println (add 1 2)) ; # =>

(infixing-plang
  (if (1 + 1 = 1 + 1)
     (println "ok")
     (println "no")))