Skip to content
Permalink
Branch: master
Find file Copy path
Find file Copy path
Fetching contributors…
Cannot retrieve contributors at this time
268 lines (234 sloc) 9.63 KB
(add-ns grmr (git-dependency "https://github.com/Toccata-Lang/grammar.git"
"grammar.toc"
:sha "1e280ff"))
(add-ns sm (git-dependency "https://github.com/Toccata-Lang/state-maybe.git"
"state-maybe.toc"
:sha "f655efc"))
(add-ns fr (git-dependency "https://github.com/Toccata-Lang/Free.git"
"free.toc"
:sha "9727acf"))
(add-ns st (git-dependency "https://github.com/Toccata-Lang/stream.git"
"stream.toc"
:sha "c778079"))
(deftype ParserState [curr-input input parser-fns values]
(assert (instance? String curr-input))
(assert (instance? HashMap parser-fns))
(assert (instance? HashMap values))
Stringable
(string-list [_] (list "<ParserState>"))
Collection
(empty? [_]
(and (empty? curr-input)
(empty? input))))
(defprotocol WrapInput
(wrap-input [_]))
(defprotocol RecursiveDescent
(recursive-descent [_]))
(defprotocol Ignored
(ignore? [_] nothing))
(extend-type grmr/get-state-value
RecursiveDescent
(recursive-descent [p]
(sm/state-maybe
(sm/new-sm (fn [parser-state]
(assert (instance? ParserState parser-state))
(or (map (get-in parser-state [.values (.key p)])
(fn [value]
[value parser-state]))
(let [_ (print-err "Could not get recursive descent state value"
(str "'" (.key p) "'"))]
(abort))))))))
(extend-type grmr/update-state-value
RecursiveDescent
(recursive-descent [p]
(sm/state-maybe
(sm/new-sm (fn [parser-state]
(assert (instance? ParserState parser-state))
(or (for [new-state (update-in parser-state [.values (.key p)] (.f p))
old-value (get-in parser-state [.values (.key p)])]
[old-value new-state])
(let [_ (print-err "Could not update recursive descent state value"
(str "'" (.key p) "'"))]
(abort))))))))
(extend-type Fn
RecursiveDescent
(recursive-descent [f]
(sm/state-maybe (fn [& rules]
(apply (sm/state-maybe (fn [& parsed-values]
(apply f (remove parsed-values ignore?))))
rules)))))
(defn next-input-buffer [s]
(assert (instance? ParserState s))
(let [input (.input s)]
(for [new-text (first input)]
(-> s
(.curr-input new-text)
(.input (either (empty? new-text)
(rest input)))))))
(defn reader [n s]
(assert (instance? ParserState s))
(let [text (.curr-input s)
text-length (count text)]
(or (and (< n text-length)
(maybe [(subs text 0 n)
(.curr-input s (subs text n))]))
(and (= n text-length)
(or (map (next-input-buffer s)
(fn [new-s]
[text new-s]))
(maybe [text (.curr-input s "")])))
;; (< text-length n)
(flat-map (next-input-buffer s)
(fn [new-s]
(let [next-read (reader (- n text-length) new-s)]
(and next-read (let [[texts final-s] (extract next-read)]
(maybe [(comp text texts) final-s])))))))))
(defn fn-reader [f s]
(assert (instance? Function f))
(assert (instance? ParserState s))
(let [text (.curr-input s)
length (f text)]
(or (and (or (= length (count text)))
(for [new-s (next-input-buffer s)
[tail final-s] (fn-reader f new-s)]
[(cons text tail) final-s]))
(and (< 0 length)
(maybe [(list (subs text 0 length))
(.curr-input s (subs text length))])))))
(extend-type grmr/parser-not-char
RecursiveDescent
(recursive-descent [p]
(sm/state-maybe
(sm/new-sm (fn [parser-state]
(assert (instance? ParserState parser-state))
(for [[c new-parser-state] (reader 1 parser-state)
:when-not (= (.test-c p) c)]
[c new-parser-state]))))))
(extend-type grmr/parser-char-range
RecursiveDescent
(recursive-descent [p]
(sm/state-maybe
(sm/new-sm (fn [parser-state]
(assert (instance? ParserState parser-state))
(for [[c new-parser-state] (reader 1 parser-state)
:when (< (dec (char-code (.lower p)))
(char-code c)
(inc (char-code (.higher p))))]
[c new-parser-state]))))))
(extend-type grmr/parser-terminal
RecursiveDescent
(recursive-descent [p]
(let [term-str (.term-str p)
term-count (count term-str)]
(sm/state-maybe (sm/new-sm (fn [parser-state]
(assert (instance? ParserState parser-state))
(for [[text new-parser-state] (reader term-count parser-state)
:when (= text term-str)]
[term-str new-parser-state])))))))
(extend-type grmr/parser-term-fn
RecursiveDescent
(recursive-descent [p]
(sm/state-maybe
(sm/new-sm (fn [s]
(assert (instance? ParserState s))
(for [[str-list new-s] (fn-reader (.f p) s)]
(let [line-count (reduce str-list 0
(fn [line-count s]
(reduce s line-count
(fn [line-count c]
(+ line-count (either (and (= c "\n")
(maybe 1))
0))))))]
[(to-str str-list)
(either (update-in new-s [.values 'line-number]
(fn [lc] (+ lc line-count)))
(assoc-in new-s [.values 'line-number] line-count))])))))))
(extend-type grmr/repeat-rule
RecursiveDescent
(recursive-descent [p]
(map (.rule p) sm/recur)))
(extend-type grmr/none-or-more-rule
RecursiveDescent
(recursive-descent [p]
(map (.rule p) (fn [rule]
(comp (sm/recur rule)
(sm/state-maybe []))))))
(extend-type grmr/ignore-rule
Stringable
(string-list [_] (list "ignored"))
RecursiveDescent
(recursive-descent [p]
(map (.rule p) (fn [rule]
(apply-to (constantly (reify
Stringable
(string-list [_] (list "<Ignored>"))
Ignored
(ignore? [_] (maybe 'ignore))))
rule)))))
(extend-type grmr/parser-always
RecursiveDescent
(recursive-descent [p]
(sm/state-maybe (sm/state-maybe (.v p)))))
(extend-type grmr/parser-rule
RecursiveDescent
(recursive-descent [p]
(.grammar p)))
(extend-type grmr/recursive-parser-rule
RecursiveDescent
(recursive-descent [p]
(for [parser (.grammar p)
_ (sm/set-val (.name p) parser)]
parser)))
(extend-type grmr/recursion-rule
RecursiveDescent
(recursive-descent [p]
(sm/state-maybe
(sm/new-sm (fn [s]
(assert (instance? ParserState s))
(either (map (get-in s [.parser-fns (.rule-name p)])
(fn [p] (p s)))
(let [_ (print-err "No parser rule defined for "
(str "'" (.rule-name p) "'"))]
(abort))))))))
(extend-type grmr/Union
RecursiveDescent
(recursive-descent [u]
(apply (sm/state-maybe (fn [& rules]
(apply comp rules)))
(.rules u))))
(extend-type grmr/Cat
RecursiveDescent
(recursive-descent [u]
(apply (sm/state-maybe (fn [& rules]
(apply (sm/state-maybe (fn [& parsed-values]
(remove parsed-values ignore?)))
rules)))
(.rules u))))
(extend-type LazyList
WrapInput
(wrap-input [x] x))
(extend-type List
WrapInput
(wrap-input [x] x))
(extend-type String
WrapInput
(wrap-input [x] (list x)))
(defn parser [grammar]
(let [grammar (grmr/string-terminal grammar)
[grammar-parser recursive-rules] (extract ((fr/evaluate grammar recursive-descent) {}))]
(fn
([input]
(flat-map (grammar-parser (ParserState "" (wrap-input input) recursive-rules {}))
first))
([values input]
(flat-map (grammar-parser (ParserState "" (wrap-input input) recursive-rules values))
first)))))
(defn parse-stream
([s grammar] (parse-stream s grammar {}))
([s grammar values]
(let [grammar (grmr/string-terminal grammar)
[grammar-parser recursive-rules] (extract ((fr/evaluate grammar recursive-descent) {}))]
(st/state-stream (ParserState "" s recursive-rules values)
(fn [stream-state]
(either (grammar-parser stream-state)
["" (ParserState "" st/empty-stream recursive-rules values)]))))))
You can’t perform that action at this time.