basis/xml/tokenize/tokenize.factor

   1 ! Copyright (C) 2005, 2009 Daniel Ehrenberg
   2 ! See https://factorcode.org/license.txt for BSD license.
   3 USING: accessors ascii assocs combinators
   4 combinators.short-circuit hints io kernel math math.parser
   5 namespaces sbufs sequences splitting strings xml.char-classes
   6 xml.entities xml.errors xml.state ;
   7 IN: xml.tokenize
   8
   9 ! * Basic utility words
  10
  11 : assure-good-char ( spot ch -- )
  12     [
  13         over {
  14             [ version-1.0?>> over text? not ]
  15             [ check>> ]
  16         } 1&&
  17         [
  18             [ [ 1 + ] change-column drop ] dip
  19             disallowed-char
  20         ] [ 2drop ] if
  21     ] [ drop ] if* ;
  22
  23 HINTS: assure-good-char { spot fixnum } ;
  24
  25 : record ( spot char -- spot )
  26     over char>> [
  27         CHAR: \n eq?
  28         [ [ 1 + ] change-line -1 ] [ dup column>> 1 + ] if
  29         >>column
  30     ] [ drop ] if ;
  31
  32 HINTS: record { spot fixnum } ;
  33
  34 :: (next) ( spot -- spot char )
  35     spot next>> :> old-next
  36     spot stream>> stream-read1 :> new-next
  37     old-next CHAR: \r eq? [
  38         spot CHAR: \n >>char
  39         new-next CHAR: \n eq?
  40         [ spot stream>> stream-read1 >>next ]
  41         [ new-next >>next ] if
  42     ] [ spot old-next >>char new-next >>next ] if
  43     spot next>> ; inline
  44
  45 : next* ( spot -- )
  46     dup char>> [ unexpected-end ] unless
  47     (next) [ record ] keep assure-good-char ;
  48
  49 HINTS: next* { spot } ;
  50
  51 : next ( -- )
  52     spot get next* ;
  53
  54 : init-parser ( -- )
  55     0 1 0 0 f t f <spot>
  56         input-stream get >>stream
  57         read1 >>next
  58     spot set next ;
  59
  60 : with-state ( stream quot -- )
  61     ! with-input-stream implicitly creates a new scope which we use
  62     swap [ init-parser call ] with-input-stream ; inline
  63
  64 :: (skip-until) ( ... quot: ( ... char -- ... ? ) spot -- ... )
  65     spot char>> [
  66         quot call [
  67             spot next* quot spot (skip-until)
  68         ] unless
  69     ] when* ; inline recursive
  70
  71 : skip-until ( ... quot: ( ... char -- ... ? ) -- ... )
  72     spot get (skip-until) ; inline
  73
  74 : take-until ( ... quot: ( ... char -- ... ? ) -- ... string )
  75     ! Take the substring of a string starting at spot
  76     ! from code until the quotation given is true and
  77     ! advance spot to after the substring.
  78     10 <sbuf> [
  79         '[ _ keep over [ drop ] [ _ push ] if ] skip-until
  80     ] keep "" like ; inline
  81
  82 : take-to ( seq -- string )
  83     '[ _ member? ] take-until ; inline
  84
  85 : pass-blank ( -- )
  86     ! Advance code past any whitespace, including newlines
  87     [ blank? not ] skip-until ;
  88
  89 : next-matching ( pos ch str -- pos' )
  90     overd nth eq? [ 1 + ] [ drop 0 ] if ; inline
  91
  92 : string-matcher ( str -- quot: ( pos char -- pos ? ) )
  93     dup length 1 - '[ _ next-matching dup _ > ] ; inline
  94
  95 :: (take-string) ( match spot -- sbuf matched? )
  96     10 <sbuf> f [
  97         spot char>> [
  98             nip over push
  99             spot next*
 100             dup match tail? dup not
 101         ] [ f ] if*
 102     ] loop ; inline
 103
 104 : take-string ( match -- string )
 105     [ spot get (take-string) [ missing-close ] unless ]
 106     [ dupd 2length - over shorten "" like ] bi ;
 107
 108 : expect ( string -- )
 109     dup length spot get '[ _ [ char>> ] keep next* ] "" replicate-as
 110     2dup = [ 2drop ] [ expected ] if ;
 111
 112 ! Suddenly XML-specific
 113
 114 : parse-named-entity ( accum string -- )
 115     [ entities at ]
 116     [ swap push ]
 117     [
 118         [ extra-entities get at ]
 119         [ swap push-all ] [ no-entity ] ?if
 120     ] ?if ;
 121
 122 : take-; ( -- string )
 123     next ";" take-to next ;
 124
 125 : parse-entity ( accum -- )
 126     take-; "#" ?head [
 127         "x" ?head 16 10 ? base> swap push
 128     ] [ parse-named-entity ] if ;
 129
 130 : parse-pe ( accum -- )
 131     take-;
 132     [ pe-table get at ]
 133     [ swap push-all ] [ no-entity ] ?if ;
 134
 135 :: (parse-char) ( quot: ( ch -- ? ) accum spot -- )
 136     spot char>> :> char
 137     {
 138         { [ char not ] [ ] }
 139         { [ char quot call ] [ spot next* ] }
 140         { [ char CHAR: & eq? ] [
 141             accum parse-entity
 142             quot accum spot (parse-char)
 143         ] }
 144         { [ char CHAR: % eq? [ in-dtd? get ] [ f ] if ] [
 145             accum parse-pe
 146             quot accum spot (parse-char)
 147         ] }
 148         [
 149             char accum push
 150             spot next*
 151             quot accum spot (parse-char)
 152         ]
 153     } cond ; inline recursive
 154
 155 : parse-char ( quot: ( ch -- ? ) -- seq )
 156     512 <sbuf> [ spot get (parse-char) ] keep "" like ; inline
 157
 158 : assure-no-]]> ( pos char -- pos' )
 159     "]]>" next-matching dup 2 > [ text-w/]]> ] when ; inline
 160
 161 :: parse-text ( -- string )
 162     depth get zero? :> no-text
 163     0 :> pos!
 164     [| char |
 165         pos char assure-no-]]> pos!
 166         no-text [
 167             char blank? char CHAR: < eq? or [
 168                 char 1string t pre/post-content
 169             ] unless
 170         ] when
 171         char CHAR: < eq?
 172     ] parse-char ;
 173
 174 : close ( -- )
 175     pass-blank ">" expect ;
 176
 177 : normalize-quote ( str -- str )
 178     [ dup "\t\r\n" member? [ drop CHAR: \s ] when ] map! ;
 179
 180 : (parse-quote) ( <-disallowed? ch -- string )
 181     swap '[
 182         dup _ eq? [ drop t ]
 183         [ CHAR: < eq? _ and [ attr-w/< ] [ f ] if ] if
 184     ] parse-char normalize-quote get-char
 185     [ unclosed-quote ] unless ; inline
 186
 187 : parse-quote* ( <-disallowed? -- seq )
 188     pass-blank get-char dup "'\"" member?
 189     [ next (parse-quote) ] [ quoteless-attr ] if ; inline
 190
 191 : parse-quote ( -- seq )
 192     f parse-quote* ;