parser combinators for Clojure https://halake.doorkeeper.jp/events/21872

parser.clj

;; parser.clj: parser combinators for Clojure
;;
;; license: http://makenowjust.github.io/license/wtfpl?2015
;; (C) 2015 TSUYUSATO Kitsune

;; parser's type:
;; String ->
;;   ((String, result) -> next) -> -- success continuation
;;   (error -> next) ->            -- failure continuation
;;   next

(defn parse [p src]
  (p src (fn [src r] [:ok src r]) (fn [err] [:error err])))

(defn parser-char
  ([]
   (fn [src success fail]
     (if (empty? src)
       (fail "no char")
       (success (.substring src 1) (.charAt src 0)))))
  ([ch]
   (fn [src success fail]
     (if (or (empty? src) (not= (.charAt src 0) ch))
       (fail (str "no match " (print-str ch)))
       (success (.substring src 1) ch)))))

(defn parser-in [chs]
  (fn [src success fail]
    (if (empty? src)
      (fail (str "no match [" chs "]"))
      (let [c (.charAt src 0)]
        (if (contains? (set chs) c)
          (success (.substring src 1) c)
          (fail (str "no match [" chs "]")))))))

(defn parser-string [s]
  (let [c (count s)]
    (fn [src success fail]
      (if (not= (.substring src 0 (min (count src) c)) s)
        (fail (str "no match " (print-str s)))
        (success (.substring src c) s)))))

(defn parser-comp [& ps]
  (fn [src success fail]
    ((fn parsing [src ps rs]
      (if (empty? ps)
        (success src rs)
        ((first ps) src
         (fn [src r] (parsing src (rest ps) (conj rs r)))
         fail))) src ps [])))

(defn parser-many [p]
  (fn many [src success fail]
    (p src
       (fn [src r] (many src (fn [src rs] (success src (into [r] rs))) fail))
       (fn [_] (success src [])))))

;(defmacro parser-let [vars expr]
;  `(fn [~'src ~'success ~'fail]
;     ~((fn parser-let [vars]
;         (if (empty? vars)
;           `(~'success ~'src ~expr)
;           (let [var (first vars)]
;             (if (list? var)
;               `(~var ~'src (fn [~'src ~(gensym)] ~(parser-let (rest vars))) ~'fail)
;               `(~(second vars) ~'src (fn [~'src ~var] ~(parser-let (drop 2 vars))) ~'fail))))) vars)))

(defmacro parser-let [vars expr]
  (let [vars (loop [vars vars
                    new-vars []]
               (if (empty? vars)
                 new-vars
                 (let [var (first vars)]
                   (if (list? var)
                     (recur (rest vars) (conj new-vars [(gensym) var]))
                     (recur (drop 2 vars) (conj new-vars [var (second vars)]))))))
        body (reduce (fn [expr [var p]]
                       `(~p ~'src (fn [~'src ~var] ~expr) ~'fail)) `(~'success ~'src ~expr) (reverse vars))]
    `(fn [~'src ~'success ~'fail] ~body)))

(defn parser-some [p]
  (parser-let [r p
               rs (parser-many p)]
              (into [r] rs)))

(defn parser-or [& ps]
  (fn [src success fail]
    ((fn parsing [ps errs]
      (if (empty? ps)
        (fail errs)
        ((first ps) src success
         (fn [err] (parsing (rest ps) (conj errs err)))))) ps [])))


;; example of an expression parser

(declare expr)

(defn number []
  (parser-let [num (parser-some (parser-in "0123456789"))]
              (read-string (apply str num))))

(defn paren []
  (parser-or (parser-let [(parser-char \()
                         e (expr)
                         (parser-char \))]
                        e)
            (number)))

(defn sign []
  (parser-or (parser-let [op (parser-in "+-")
                          e (sign)]
                         {:type :sign,
                          :op op, :expr e})
             (paren)))

(defn stmt []
  (parser-let [e (sign)
               opEs (parser-many (parser-comp (parser-in "*/") (sign)))]
              (reduce (fn [l [op r]] {:type :binary,
                                       :op op, :left l, :right r}) e opEs)))

(defn expr []
  (parser-let [e (stmt)
               opEs (parser-many (parser-comp (parser-in "+-") (stmt)))]
              (reduce (fn [l [op r]] {:type :binary,
                                       :op op, :left l, :right r}) e opEs)))

(parse (expr) "123+456*(1/3)")