Skip to content
Permalink
Branch: master
Find file Copy path
Find file Copy path
Fetching contributors…
Cannot retrieve contributors at this time
168 lines (122 sloc) 4.02 KB
(add-ns fr (git-dependency "https://github.com/Toccata-Lang/Free.git"
"free.toc"
:sha "9727acf"))
(deftype get-state-value [key])
(defn get-value [key]
(fr/pure (get-state-value key)))
(deftype update-state-value [key f])
(defn update-value [key f]
(fr/pure (update-state-value key f)))
(deftype parser-not-char [test-c])
(defn not-char [test-c]
(fr/pure (parser-not-char test-c)))
(deftype parser-char-range [lower higher])
(defn char-range [lower higher]
(fr/pure (parser-char-range lower higher)))
(deftype parser-term-fn [f])
(defn term-fn [f]
(fr/pure (parser-term-fn f)))
(deftype parser-terminal [term-str]
Stringable
(string-list [_] (list "<Term " (str term-str) ">")))
;; too much of a perf hit to write in terms of 'term-fn'
(defn term [term-str]
(fr/pure (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 [_] (comp (list "<Repeat ")
(string-list rule)
(list ">")))
Container
(map [_ f]
(repeat-rule (f rule))))
(defn one-or-more [rule]
(fr/free-monad (repeat-rule (string-terminal rule))))
(deftype ignore-rule [rule]
Container
(map [_ f]
(ignore-rule (f rule))))
(defn ignore [rule]
(fr/free-monad (ignore-rule (string-terminal rule))))
(deftype parser-always [v])
(defn always [v]
(fr/pure (parser-always v)))
(deftype Cat [rules]
(assert (instance? List rules))
Stringable
(string-list [_] (comp (list "<ParserConcat ")
(flat-map (interpose rules ", ") string-list)
(list ">")))
Container
(map [_ f]
(Cat (map rules f))))
(defn all [& rules]
(fr/free-monad (Cat (map rules string-terminal))))
(deftype Union [rules]
(assert (instance? List rules))
Stringable
(string-list [_] (comp (list "<ParserUnion ")
(flat-map (interpose rules ", ") string-list)
(list ">")))
Container
(map [_ f]
(Union (map rules f))))
(defn any [& rules]
(fr/free-monad (Union (map rules string-terminal))))
(deftype none-or-more-rule [rule]
Stringable
(string-list [_]
(list "none-or-more"))
Container
(map [_ f]
(none-or-more-rule (f rule))))
(defn none-or-more [rule]
(fr/free-monad (none-or-more-rule (string-terminal rule))))
(deftype parser-rule [name grammar]
Stringable
(string-list [_] (comp (list "<ParserRule " (str name) " ")
(string-list grammar)
(list ">")))
Container
(map [_ f]
(parser-rule name (f grammar))))
(defn rule [name grammar]
(fr/free-monad (parser-rule name (string-terminal grammar))))
(deftype recursive-parser-rule [name grammar]
Stringable
(string-list [_]
(list "<RecursiveRule " (str name) ">"))
Container
(map [_ f]
(recursive-parser-rule name (f grammar))))
(defn recursive-rule [name grammar]
(fr/free-monad (recursive-parser-rule name (string-terminal grammar))))
(deftype recursion-rule [rule-name]
Stringable
(string-list [_]
(list "<RecursionRule " rule-name ">")))
(defn recurse [rule-name]
(fr/pure (recursion-rule rule-name)))
(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 (seq coll)))
(defn apply-fn [f & rules]
(apply (fr/pure f) (map rules string-terminal)))
(defn optional [rule]
(any (apply (fr/pure (fn ([] (maybe ""))
([x] (maybe x))))
(list (string-terminal rule)))
(apply (fr/pure (constantly nothing))
(list (term "")))))
You can’t perform that action at this time.