1 files changed, 143 insertions, 0 deletions
diff --git a/parser/parser.fnl b/parser/parser.fnl
new file mode 100644
index 0000000..b52f881
--- /dev/null
+++ b/parser/parser.fnl
@@ -0,0 +1,143 @@
+(import-macros {: map} :lib.macro)
+
+(local number (require :lib.number))
+
+(local peg
+ (if (pick-values 1 (pcall require :lpeg))
+   (require :lpeg)
+   (require :lpeglj)))
+
+;; "not" is taken >:(
+(fn pnot [p]
+  (- (peg.P 1) (peg.P p)))
+
+(fn till [p]
+  (^ (pnot p) 1))
+
+(fn maybe [p]
+  (^ (peg.P p) 0))
+
+(fn anywhere [p]
+  (peg.P [(+ p (* 1 (peg.V 1)))]))
+
+(local pegs {})
+(tset pegs :number (^ (peg.R "09") 1))
+(tset pegs :letters (^ (+ (peg.R "az") (peg.R "AZ")) 1))
+(tset pegs :space (peg.S "\n\t "))
+(tset pegs :spaces (^ (peg.S "\n\t ") 1))
+(tset pegs :tag-name (+ pegs.letters pegs.number))
+(tset pegs :attr
+      (peg.Ct (* (peg.Cg (^ (+ pegs.letters "-") 1) :name)
+                 (maybe (* "=\"" (peg.Cg (till "\"") :value) "\"")))))
+(tset pegs :self-closing-tag
+      (* "<"
+         (peg.Cg
+           (+ (peg.P "area") "base" "br" "col" "embed" "hr"
+              "img" "input" "link" "meta" "param" "source"
+              "track" "wbr") ;; should be case insensitive
+           :tag)
+         (peg.Cg (peg.Ct (^ (+ pegs.space (peg.Cg pegs.attr)) 0)) :attrs)
+         (maybe "/") ">"))
+(tset pegs :opening-tag
+      (* "<" (peg.Cg pegs.tag-name :tag)
+         (peg.Cg (peg.Ct (^ (+ pegs.space (peg.Cg pegs.attr)) 0)) :attrs)
+         ">"))
+(tset pegs :closing-tag (* "</" pegs.tag-name ">"))
+(tset pegs :doctype
+      (* "<!DOCTYPE HTML" (^ pegs.attr 0) ">")) ;; should be case insensitive
+(tset pegs :tag
+      (peg.P [(peg.Ct (+ pegs.self-closing-tag
+                         (* pegs.opening-tag
+                            (peg.Cg
+                              (peg.Ct
+                                (^ (+ (+ pegs.space (peg.V 1))
+                                      (peg.Cg (till pegs.closing-tag)))
+                                   0))
+                              :nodes)
+                            pegs.closing-tag)))]))
+(tset pegs :html
+      (* pegs.doctype (peg.Ct (^ (+ pegs.space (peg.Cg pegs.tag)) 0))))
+
+(fn tag [tag attrs contents]
+  (local tag (peg.P tag))
+  (local attrs-count (accumulate [sum 0 _ _ (pairs attrs)] (+ 1 sum)))
+  (local attr-peg
+    (fn [name value] (*
+                      (^ (peg.P name) 1)
+                      (if (~= value "")
+                        (* "=\""
+                           ;; wildcard for any value
+                           (if (= value "*")
+                               (till "\"")
+                               (peg.P value))
+                           "\"")
+                      (maybe (.. "=\" name \""))))))
+  (local attrs-peg
+    (accumulate [sum pegs.spaces 
+                 _ rule
+                 (pairs (icollect [k v (pairs attrs)]
+                          (attr-peg k v)))]
+      (+ rule sum)))
+  (if contents
+    (peg.P (*
+            (^ pegs.space 0)
+            ;; opening tag
+            (* "<" tag (^ pegs.space 0)
+               (^ attrs-peg (- (* attrs-count 2) 1))
+               (^ pegs.space 0) ">")
+            ;; tag contents
+            (^ pegs.space 0)
+            (if (= contents "*")
+              (till (* "</" tag ">"))
+              contents)
+            (^ pegs.space 0)
+            ;; closing tag
+            (* "</" tag ">")))
+    (peg.P (*
+            (^ pegs.space 0)
+            ;; opening tag
+            (* "<" tag (^ pegs.space 0)
+               (^ attrs-peg (- (* attrs-count 2) 1))
+               (^ pegs.space 0) (maybe "/") ">")))))
+
+(fn match-many [html tag]
+  (: (peg.Ct (^ (peg.Ct tag) 1))
+     :match html))
+
+(fn guess-category [title]
+  (if (: (anywhere (+ (peg.P "зеленый") "Зеленый")) :match title)
+    "Зеленый чай"
+   (: (anywhere (+ (peg.P "Улун") "улун")) :match title)
+    "Улун"
+   (: (anywhere (+ (peg.P "Белый") "белый")) :match title)
+    "Белый чай"
+   (: (anywhere (+ (peg.P "Желтый") "желтый")) :match title)
+    "Желтый чай"
+   (: (anywhere (+ (peg.P "Красный") "красный")) :match title)
+    "Красный чай"
+   "Неизвестная категория"))
+
+(fn guess-year [title]
+  (number.string->number
+   (: (anywhere
+       (* (peg.C (^ (peg.R "09") 4))
+           (maybe " ")
+           (- "г" (peg.P "гр"))))
+      :match title)))
+
+(fn guess-weight [title]
+  (number.string->number
+   (: (anywhere
+       (* (peg.C pegs.number) (maybe " ") "гр"))
+      :match title)))
+
+{: match-many
+ : tag
+ : anywhere
+ : till
+ : maybe
+ : pegs
+ :not pnot
+ : guess-category
+ : guess-year
+ : guess-weight}