basis/html/parser/analyzer/analyzer.factor

   1 USING: assocs html.parser kernel math sequences strings ascii
   2 arrays generalizations shuffle unicode.case namespaces splitting
   3 http sequences.lib accessors io combinators http.client urls ;
   4 IN: html.parser.analyzer
   5
   6 TUPLE: link attributes clickable ;
   7
   8 : scrape-html ( url -- vector )
   9     http-get nip 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             [ [ blank? ] trim ] change-text
  60         ] 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     >r >lower r>
  71     [ name>> = ] with filter ;
  72
  73 : find-first-name ( str vector -- i/f tag/f )
  74     >r >lower r>
  75     [ name>> = ] with find ;
  76
  77 : find-matching-close ( str vector -- i/f tag/f )
  78     >r >lower r>
  79     [ [ name>> = ] keep closing?>> and ] with find ;
  80
  81 : find-by-attribute-key ( key vector -- vector )
  82     >r >lower r>
  83     [ attributes>> at ] with filter
  84     sift ;
  85
  86 : find-by-attribute-key-value ( value key vector -- vector )
  87     >r >lower r>
  88     [ attributes>> at over = ] with filter nip
  89     sift ;
  90
  91 : find-first-attribute-key-value ( value key vector -- i/f tag/f )
  92     >r >lower r>
  93     [ attributes>> at over = ] with find rot drop ;
  94
  95 : find-between* ( i/f tag/f vector -- vector )
  96     pick integer? [
  97         rot tail-slice
  98         >r name>> r>
  99         [ find-matching-close drop dup [ 1+ ] when ] keep
 100         swap [ head ] [ first ] if*
 101     ] [
 102         3drop V{ } clone
 103     ] if ;
 104
 105 : find-between ( i/f tag/f vector -- vector )
 106     find-between* dup length 3 >= [
 107         [ rest-slice but-last-slice ] keep like
 108     ] when ;
 109
 110 : find-between-first ( string vector -- vector' )
 111     [ find-first-name ] keep find-between ;
 112
 113 : find-between-all ( vector quot -- seq )
 114     [ [ [ closing?>> not ] bi and ] curry find-all ] curry
 115     [ [ >r first2 r> find-between* ] curry map ] bi ;
 116
 117 : tag-link ( tag -- link/f )
 118     attributes>> [ "href" swap at ] [ f ] if* ;
 119
 120 : find-links ( vector -- vector' )
 121     [ [ name>> "a" = ] [ attributes>> "href" swap at ] bi and ]
 122     find-between-all ;
 123
 124 : <link> ( vector -- link )
 125     [ first attributes>> ]
 126     [ [ name>> { text "img" } member? ] filter ] bi
 127     link boa ;
 128
 129 : link. ( vector -- )
 130     [ attributes>> "href" swap at write nl ]
 131     [ clickable>> [ bl bl text>> print ] each nl ] bi ;
 132
 133 : find-by-text ( seq quot -- tag )
 134     [ dup name>> text = ] prepose find drop ;
 135
 136 : find-opening-tags-by-name ( name seq -- seq )
 137     [ [ name>> = ] keep closing?>> not and ] with find-all ;
 138
 139 : href-contains? ( str tag -- ? )
 140     attributes>> "href" swap at* [ subseq? ] [ 2drop f ] if ;
 141
 142 : find-hrefs ( vector -- vector' )
 143     find-links
 144     [ [
 145         [ name>> "a" = ]
 146         [ attributes>> "href" swap key? ] bi and ] filter
 147     ] map sift [ [ attributes>> "href" swap at ] map ] map concat ;
 148
 149 : find-forms ( vector -- vector' )
 150     "form" over find-opening-tags-by-name
 151     swap [ >r first2 r> find-between* ] curry map
 152     [ [ name>> { "form" "input" } member? ] filter ] map ;
 153
 154 : find-html-objects ( string vector -- vector' )
 155     [ find-opening-tags-by-name ] keep
 156     [ >r first2 r> find-between* ] curry map ;
 157
 158 : form-action ( vector -- string )
 159     [ name>> "form" = ] find nip
 160     attributes>> "action" swap at ;
 161
 162 : hidden-form-values ( vector -- strings )
 163     [ attributes>> "type" swap at "hidden" = ] filter ;
 164
 165 : input. ( tag -- )
 166     dup name>> print
 167     attributes>>
 168     [ bl bl bl bl [ write "=" write ] [ write bl ] bi* nl ] assoc-each ;
 169
 170 : form. ( vector -- )
 171     [ closing?>> not ] filter
 172     [
 173         {
 174             { [ dup name>> "form" = ]
 175                 [ "form action: " write attributes>> "action" swap at print ] }
 176             { [ dup name>> "input" = ] [ input. ] }
 177             [ drop ]
 178         } cond
 179     ] each ;
 180
 181 : query>assoc* ( str -- hash )
 182     "?" split1 nip query>assoc ;