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 sequences.lib accessors io combinators
   4 http.client urls ;
   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-relative)
  13     [ >r + dup r> ?nth* [ 2drop f f ] unless ] [ 2drop f ] if ; inline
  14
  15 : find-relative ( seq quot n -- i elt )
  16     >r over [ find drop ] dip r> swap pick
  17     (find-relative) ; inline
  18
  19 : (find-all) ( n seq quot -- )
  20     2dup >r >r find-from [
  21         dupd 2array , 1+ r> r> (find-all)
  22     ] [
  23         r> r> 3drop
  24     ] if* ; inline
  25
  26 : find-all ( seq quot -- alist )
  27     [ 0 -rot (find-all) ] { } make ; inline
  28
  29 : (find-nth) ( offset seq quot n count -- obj )
  30     >r >r [ find-from ] 2keep 4 npick [
  31         r> r> 1+ 2dup <= [
  32             4drop
  33         ] [
  34             >r >r >r >r drop 1+ r> r> r> r>
  35             (find-nth)
  36         ] if
  37     ] [
  38         2drop r> r> 2drop
  39     ] if ; inline
  40
  41 : find-nth ( seq quot n -- i elt )
  42     0 -roll 0 (find-nth) ; inline
  43
  44 : find-nth-relative ( seq quot n offest -- i elt )
  45     >r [ find-nth ] 3keep 2drop nip r> swap pick
  46     (find-relative) ; inline
  47
  48 : remove-blank-text ( vector -- vector' )
  49     [
  50         dup name>> text = [
  51             text>> [ blank? ] all? not
  52         ] [
  53             drop t
  54         ] if
  55     ] filter ;
  56
  57 : trim-text ( vector -- vector' )
  58     [
  59         dup name>> text = [
  60             [ [ blank? ] trim ] change-text
  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 : find-hrefs ( vector -- vector' )
 144     find-links
 145     [ [
 146         [ name>> "a" = ]
 147         [ attributes>> "href" swap key? ] bi and ] filter
 148     ] map sift [ [ attributes>> "href" swap at ] map ] map concat ;
 149
 150 : find-forms ( vector -- vector' )
 151     "form" over find-opening-tags-by-name
 152     swap [ >r first2 r> find-between* ] curry map
 153     [ [ name>> { "form" "input" } member? ] filter ] map ;
 154
 155 : find-html-objects ( string vector -- vector' )
 156     [ find-opening-tags-by-name ] keep
 157     [ >r first2 r> find-between* ] curry map ;
 158
 159 : form-action ( vector -- string )
 160     [ name>> "form" = ] find nip
 161     attributes>> "action" swap at ;
 162
 163 : hidden-form-values ( vector -- strings )
 164     [ attributes>> "type" swap at "hidden" = ] filter ;
 165
 166 : input. ( tag -- )
 167     dup name>> print
 168     attributes>>
 169     [ bl bl bl bl [ write "=" write ] [ write bl ] bi* nl ] assoc-each ;
 170
 171 : form. ( vector -- )
 172     [ closing?>> not ] filter
 173     [
 174         {
 175             { [ dup name>> "form" = ]
 176                 [ "form action: " write attributes>> "action" swap at print ] }
 177             { [ dup name>> "input" = ] [ input. ] }
 178             [ drop ]
 179         } cond
 180     ] each ;
 181
 182 : query>assoc* ( str -- hash )
 183     "?" split1 nip query>assoc ;