basis/xml/tokenize/tokenize.factor

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