1 files changed, 108 insertions, 0 deletions
diff --git a/parser.fnl b/parser.fnl
new file mode 100644
index 0000000..314476c
--- /dev/null
+++ b/parser.fnl
@@ -0,0 +1,108 @@
+(import-macros {: map} :lib.macro)
+(local peg
+ (if (pick-values 1 (pcall require :lpeg))
+   (require :lpeg)
+   (require :vendor.lpeglj)))
+
+(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))
+
+{: match-many
+ : tag
+ : anywhere
+ : till
+ : maybe
+ : pegs
+ :not pnot}