(import-macros {: map} :lib.macro) (local number (require :lib.number)) (local {: must} (require :lib.utils)) (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 (* "")) (tset pegs :doctype (* "")) ;; 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 (* "")) contents) (^ pegs.space 0) ;; closing 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)) ;; FIXME: make guessing case insensitive (fn guess-tags [text] (local text (if text (must (luna.utf.lower text)) "")) (if (: (anywhere (peg.P "зеленый чай")) :match text) ["Зеленый чай"] (: (anywhere (peg.P "улун")) :match text) ["Улун"] (: (anywhere (peg.P "белый чай")) :match text) ["Белый чай"] (: (anywhere (peg.P "желтый чай")) :match text) ["Желтый чай"] (: (anywhere (peg.P "красный чай")) :match text) ["Красный чай"] (: (anywhere (peg.P "хэй ча")) :match text) ["Хэй ча"] (: (anywhere (peg.P "шу пуэр")) :match text) ["Шу пуэр"] (: (anywhere (+ (peg.P "шен пуэр") "шэн пуэр")) :match text) ["Шен пуэр"] (: (anywhere (+ (peg.P "матча") "маття")) :match text) ["Матча"] [])) (fn guess-year [text] (number.string->number (: (anywhere (* (peg.C (^ (peg.R "09") 4)) (maybe " ") (- (+ (peg.P "г") "год") (peg.P "гр")))) :match text))) (fn guess-weight [text] (if text (number.string->number (: (anywhere (* (peg.C pegs.number) (maybe " ") "гр")) :match text)) nil)) {: match-many : tag : anywhere : till : maybe : pegs :not pnot : guess-tags : guess-year : guess-weight}