grammar.toc

(deftype parser-apply [pf args]
  Stringable
  (string-list [_]
    (list "(parser-apply " (str pf)
          "\n[" (to-str (interpose args "\n")) "])"))

  Container
  (map [r f]
    (let [new-pf (f pf)
          new-args (map args f)]
      (parser-apply new-pf new-args)))

  (map [r f embed]
    (for [new-pf (f pf)
          new-args (map args f embed)]
      (parser-apply new-pf new-args))))

(deftype parser-always [value]
  Stringable
  (string-list [_]
    (list "(parser-always " (str value) ")"))

  Container
  (map [x f]
    x)

  (map [x f embed]
    (embed x)))

(defn always [v]
  (parser-always v))

(deftype error-value [msg]
  Stringable
  (string-list [_]
    (list (str "(error-value " msg ")")))

  Container
  (map [x f]
    x)

  (map [x f embed]
    (embed x)))

(defn error [& msgs]
  (-> msgs
      (interpose " ")
      to-str
      error-value))

(deftype parser-get-text []
  Stringable
  (string-list [_]
    (list (str "(parser-get-text)")))

  Container
  (map [x f]
    x)

  (map [x f embed]
    (embed x)))

(def get-text (parser-get-text))

(deftype error-catcher [handler rule]
  Stringable
  (string-list [_]
    (list (str "(error-catcher " handler " " rule ")")))

  Container
  (map [x f]
    (.rule x (f x)))

  (map [x f embed]
    (map (f x)
         (partial .rule x))))

(defn catch-error [f rule]
  (error-catcher f rule))

(deftype get-state-value [key]
  Stringable
  (string-list [_]
    (list (str "(get-state-value '" key ")")))

  Container
  (map [x f]
    x)
  
  (map [x f embed]
    (embed x)))

(defn get-value [key]
  (get-state-value key))

(deftype update-state-value [key f]
  Stringable
  (string-list [_]
    (list "(update-state-value " (str key) " " (str f) ")"))

  Container
  (map [x _]
    x)
  
  (map [x _ embed]
    (embed x)))

(defn update-value [key f]
  (update-state-value key f))

(deftype parser-not-char [test-c]
  Stringable
  (string-list [_]
    (list "(parser-not-char " (str "\"" (escape-chars test-c) "\"") ")"))
  
  Container
  (map [x _]
    x)
  
  (map [x _ embed]
    (embed x)))

(defn not-char [test-c]
  (assert (instance? String test-c))

  (parser-not-char test-c))

(deftype parser-char-range [lower higher]
  Stringable
  (string-list [_]
    (list "(parser-char-range " (str "\"" lower "\"") " " (str "\"" higher "\"") ")"))

  Container
  (map [x f]
    x)

  (map [x f embed]
    (embed x)))

(defn char-range [lower higher]
  (assert (instance? String lower))
  (assert (instance? String higher))

  (parser-char-range lower higher))

(deftype parser-term-fn [f]
  Stringable
  (string-list [_]
    (list "(parser-term-fn " (str f) ")"))

  Container
  (map [x _]
    x)

  (map [x _ embed]
    (embed x)))

(defn term-fn [f]
  (parser-term-fn f))

(deftype parser-terminal [term-str]
  (assert (instance? String term-str))

  Stringable
  (string-list [_] (list "(parser-terminal "
                         (str "\"" (escape-chars term-str) "\"") ")"))

  Container
  (map [x f]
    x)

  (map [x f embed]
    (embed x)))

;; too much of a perf hit to write in terms of 'term-fn'
;; but maybe not now
(defn term [term-str]
  (parser-terminal term-str))

(defprotocol StringTerminal
  (string-terminal [rule]
    rule))

(extend-type String
  StringTerminal
  (string-terminal [s]
    (term s)))

(deftype repeat-rule [rule]
  Stringable
  (string-list [_]
    (list "(repeat-rule " (str rule) ")"))

  Container
  (map [_ f]
    (repeat-rule (f rule)))

  (map [_ f embed]
    (map (f rule)
         repeat-rule)))

(defn one-or-more [rule]
  (repeat-rule rule))

(deftype none-or-more-rule [rule]
  Stringable
  (string-list [_]
    (list "(none-or-more " (str rule) ")"))

  Container
  (map [_ f]
    (none-or-more-rule (f rule)))

  (map [_ f embed]
    (map (f rule)
         none-or-more-rule)))

(defn none-or-more [rule]
  (none-or-more-rule rule))

(deftype ignore-rule [rule]
  Stringable
  (string-list [_]
    (list "(ignore-rule " (str rule) ")"))

  Container
  (map [_ f]
    (ignore-rule (f rule)))

  (map [_ f embed]
    (map (f rule) ignore-rule)))

(defn ignore [rule]
  (ignore-rule rule))

(deftype Any-rule [rules]
  (assert (instance? Vector rules))
  ;; min-count rules 1

  Stringable
  (string-list [_] (comp (list "(Any-rule [")
                         (flat-map (interpose rules "\n") string-list)
                         (list "])")))

  Container
  (map [_ f]
    (Any-rule (map rules f)))

  (map [_ f embed]
    (map (map rules f embed)
         Any-rule)))

(defn any [& rules]
  (Any-rule (vec rules)))

(deftype All-rule [rules]
  (assert (instance? Vector rules))
  ;; min-count rules 1

  Stringable
  (string-list [_] (comp (list "(All-rule [")
                         (flat-map (interpose rules "\n") string-list)
                         (list "])")))

  Container
  (map [_ f]
    (All-rule (map rules f)))

  (map [_ f embed]
    (map (map rules f embed)
         All-rule)))

(defn all [& rules]
  (All-rule (vec rules)))

(defn optional
  ([rule] (optional (parser-apply (parser-always maybe)
                                  [rule])
                    nothing))
  ([rule default-value]
   (any rule (parser-always default-value))))

(deftype recursion-rule [rule-name]
  Stringable
  (string-list [_]
    (list "(recursion-rule " rule-name ")"))

  Container
  (map [x f]
    x)

  (map [x f embed]
    (embed x)))

(defn recurse [rule-name]
  (recursion-rule rule-name))

(deftype parser-rule [name rule]
  Stringable
  (string-list [_] (comp (list "(parser-rule\n" (str "\"" name "\"") "\n")
                         (string-list rule)
                         (list ")")))

  Container
  (map [_ f]
    (parser-rule name (f rule)))

  (map [_ f embed]
    (map (f rule)
         (partial parser-rule name))))

(defn rule [rule-name grammar]
  (parser-rule rule-name grammar))

(def lower-alpha (rule "lower-alpha" (char-range "a" "z")))
(def upper-alpha (rule "upper-alpha" (char-range "A" "Z")))
(def alpha (rule "alpha" (any lower-alpha upper-alpha)))
(def digit (rule "digit" (char-range "0" "9")))
(def alphanum (rule "alphanum" (any alpha digit)))
(def hex (rule "hex" (any digit
                          (char-range "a" "f")
                          (char-range "A" "F"))))

(defn one-of [coll]
  (apply any (vec coll)))

(defn apply-fn [f & rules]
  (apply f (map rules string-terminal)))

(def ParserElement (any-of parser-always
                           parser-apply
                           error-value
                           parser-rule
                           parser-get-text
                           error-catcher
                           get-state-value
                           update-state-value
                           parser-not-char
                           parser-char-range
                           parser-term-fn
                           parser-terminal
                           none-or-more-rule
                           All-rule
                           Any-rule
                           ignore-rule
                           repeat-rule
                           recursion-rule))

(extend-type ParserElement
  Container
  (wrap [_ x]
    (parser-always x))

  (apply [xf xs]
    (parser-apply xf xs)))