extra/html/parser/analyzer/analyzer.factor

   1 USING: assocs html.parser kernel math sequences strings ascii
   2 arrays generalizations shuffle unicode.case namespaces make
   3 splitting http accessors io combinators http.client urls
   4 fry sequences.lib ;
   5 IN: html.parser.analyzer
   6
   7 TUPLE: link attributes clickable ;
   8
   9 : scrape-html ( url -- vector )
  10     http-get nip parse-html ;
  11
  12 : find-all ( seq quot -- alist )
  13    [ <enum> >alist ] [ '[ second @ ] ] bi* filter ; inline
  14
  15 : find-nth ( seq quot n -- i elt )
  16     [ <enum> >alist ] 2dip -rot
  17     '[ _ [ second @ ] find-from rot drop swap 1+ ]
  18     [ f 0 ] 2dip times drop first2 ; inline
  19
  20
  21 : find-first-name ( str vector -- i/f tag/f )
  22     [ >lower ] dip [ name>> = ] with find ; inline
  23
  24 : find-matching-close ( str vector -- i/f tag/f )
  25     [ >lower ] dip
  26     [ [ name>> = ] [ closing?>> ] bi and ] with find ; inline
  27
  28 : find-between* ( i/f tag/f vector -- vector )
  29     pick integer? [
  30         rot tail-slice
  31         >r name>> r>
  32         [ find-matching-close drop dup [ 1+ ] when ] keep
  33         swap [ head ] [ first ] if*
  34     ] [
  35         3drop V{ } clone
  36     ] if ; inline
  37
  38 : find-between ( i/f tag/f vector -- vector )
  39     find-between* dup length 3 >= [
  40         [ rest-slice but-last-slice ] keep like
  41     ] when ; inline
  42
  43 : find-between-first ( string vector -- vector' )
  44     [ find-first-name ] keep find-between ; inline
  45
  46 : find-between-all ( vector quot -- seq )
  47     [ [ [ closing?>> not ] bi and ] curry find-all ] curry
  48     [ [ >r first2 r> find-between* ] curry map ] bi ; inline
  49
  50
  51 : remove-blank-text ( vector -- vector' )
  52     [
  53         dup name>> text =
  54         [ text>> [ blank? ] all? not ] [ drop t ] if
  55     ] filter ;
  56
  57 : trim-text ( vector -- vector' )
  58     [
  59         dup name>> text =
  60         [ [ [ blank? ] trim ] change-text ] when
  61     ] map ;
  62
  63 : find-by-id ( id vector -- vector )
  64     [ attributes>> "id" swap at = ] with filter ;
  65
  66 : find-by-class ( id vector -- vector )
  67     [ attributes>> "class" swap at = ] with filter ;
  68
  69 : find-by-name ( str vector -- vector )
  70     [ >lower ] dip [ name>> = ] with filter ;
  71
  72 : find-by-attribute-key ( key vector -- vector )
  73     [ >lower ] dip
  74     [ attributes>> at ] with filter
  75     sift ;
  76
  77 : find-by-attribute-key-value ( value key vector -- vector )
  78     [ >lower ] dip
  79     [ attributes>> at over = ] with filter nip
  80     sift ;
  81
  82 : find-first-attribute-key-value ( value key vector -- i/f tag/f )
  83     [ >lower ] dip
  84     [ attributes>> at over = ] with find rot drop ;
  85
  86 : tag-link ( tag -- link/f )
  87     attributes>> [ "href" swap at ] [ f ] if* ;
  88
  89 : find-links ( vector -- vector' )
  90     [ [ name>> "a" = ] [ attributes>> "href" swap at ] bi and ]
  91     find-between-all ;
  92
  93 : <link> ( vector -- link )
  94     [ first attributes>> ]
  95     [ [ name>> { text "img" } member? ] filter ] bi
  96     link boa ;
  97
  98 : link. ( vector -- )
  99     [ attributes>> "href" swap at write nl ]
 100     [ clickable>> [ bl bl text>> print ] each nl ] bi ;
 101
 102 : find-by-text ( seq quot -- tag )
 103     [ dup name>> text = ] prepose find drop ;
 104
 105 : find-opening-tags-by-name ( name seq -- seq )
 106     [ [ name>> = ] [ closing?>> not ] bi and ] with find-all ;
 107
 108 : href-contains? ( str tag -- ? )
 109     attributes>> "href" swap at* [ subseq? ] [ 2drop f ] if ;
 110
 111 : find-hrefs ( vector -- vector' )
 112     find-links
 113     [ [
 114         [ name>> "a" = ]
 115         [ attributes>> "href" swap key? ] bi and ] filter
 116     ] map sift [ [ attributes>> "href" swap at ] map ] map concat ;
 117
 118 : find-forms ( vector -- vector' )
 119     "form" over find-opening-tags-by-name
 120     swap [ >r first2 r> find-between* ] curry map
 121     [ [ name>> { "form" "input" } member? ] filter ] map ;
 122
 123 : find-html-objects ( string vector -- vector' )
 124     [ find-opening-tags-by-name ] keep
 125     [ [ first2 ] dip find-between* ] curry map ;
 126
 127 : form-action ( vector -- string )
 128     [ name>> "form" = ] find nip
 129     attributes>> "action" swap at ;
 130
 131 : hidden-form-values ( vector -- strings )
 132     [ attributes>> "type" swap at "hidden" = ] filter ;
 133
 134 : input. ( tag -- )
 135     dup name>> print
 136     attributes>>
 137     [ bl bl bl bl [ write "=" write ] [ write bl ] bi* nl ] assoc-each ;
 138
 139 : form. ( vector -- )
 140     [ closing?>> not ] filter
 141     [
 142         {
 143             { [ dup name>> "form" = ]
 144                 [ "form action: " write attributes>> "action" swap at print ] }
 145             { [ dup name>> "input" = ] [ input. ] }
 146             [ drop ]
 147         } cond
 148     ] each ;
 149
 150 : query>assoc* ( str -- hash )
 151     "?" split1 nip query>assoc ;