extra/html/parser/analyzer/analyzer.factor

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