forked from threatgrid/naga
-
Notifications
You must be signed in to change notification settings - Fork 2
/
expression.cljc
54 lines (44 loc) · 1.7 KB
/
expression.cljc
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
(ns naga.lang.expression
(:require #?(:clj [the.parsatron :refer [defparser let->> >> many attempt always]]
:cljs [the.parsatron :refer [many attempt always]
:refer-macros [defparser let->> >>]])
[naga.lang.basic :refer
[whitespace-char opt-whitespace separator open-paren close-paren
equals not-equals lt gt lte gte
plus minus tms divd
elt pstring
choice* either*]]))
(def relation (choice* equals not-equals lt gt lte gte))
(def plus-op (either* plus minus))
(def mult-op (either* divd tms))
(def fn-symbol
{\= =, "!=" not=, \< <, \> >, "<=" <=, ">=" >=,
\+ +, \- -, \* *, \/ /})
(defn flatten-expr
[op1 op2 f r]
(let [p (keep (fn [[o opnd]] (if (= op1 o) opnd)) r)
m (keep (fn [[o opnd]] (if (= op2 o) opnd)) r)]
(if (seq p)
(if (seq m)
(apply list (fn-symbol op2) (apply list (fn-symbol op1) f p) m)
(apply list (fn-symbol op1) f p))
(if (seq m)
(apply list (fn-symbol op2) f m)
f))))
(defparser mult-expr []
(let->> [op (>> opt-whitespace mult-op)
e (>> opt-whitespace (elt))]
(always [op e])))
(defparser multiplicative-expr []
(let->> [unry (elt)
munry (many (attempt (mult-expr)))]
(always (flatten-expr \* \/ unry munry))))
(defparser add-expr []
(let->> [op (>> opt-whitespace plus-op)
e (>> opt-whitespace (multiplicative-expr))]
(always [op e])))
(defparser additive-expr []
(let->> [mult (multiplicative-expr)
mmult (many (attempt (add-expr)))]
(always (flatten-expr \+ \- mult mmult))))
(def expression (choice* (additive-expr) pstring))