core/strings/parser/parser.factor

   1 ! Copyright (C) 2008, 2009 Slava Pestov, Doug Coleman.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors arrays assocs combinators kernel kernel.private
   4 lexer math math.parser namespaces sbufs sequences splitting
   5 strings ;
   6 IN: strings.parser
   7
   8 ERROR: bad-escape char ;
   9
  10 : escape ( escape -- ch )
  11     H{
  12         { CHAR: a  CHAR: \a }
  13         { CHAR: b  CHAR: \b }
  14         { CHAR: e  CHAR: \e }
  15         { CHAR: f  CHAR: \f }
  16         { CHAR: n  CHAR: \n }
  17         { CHAR: r  CHAR: \r }
  18         { CHAR: t  CHAR: \t }
  19         { CHAR: s  CHAR: \s }
  20         { CHAR: v  CHAR: \v }
  21         { CHAR: \s CHAR: \s }
  22         { CHAR: 0  CHAR: \0 }
  23         { CHAR: \\ CHAR: \\ }
  24         { CHAR: \" CHAR: \" }
  25     } ?at [ bad-escape ] unless ;
  26
  27 SYMBOL: name>char-hook
  28
  29 name>char-hook [
  30     [ "Unicode support not available" throw ]
  31 ] initialize
  32
  33 : hex-escape ( str -- ch str' )
  34     2 cut-slice [ hex> ] dip ;
  35
  36 : unicode-escape ( str -- ch str' )
  37     "{" ?head-slice [
  38         CHAR: } over index cut-slice
  39         [ >string name>char-hook get call( name -- char ) ] dip
  40         rest-slice
  41     ] [
  42         6 cut-slice [ hex> ] dip
  43     ] if ;
  44
  45 : next-escape ( str -- ch str' )
  46     unclip-slice {
  47         { CHAR: u [ unicode-escape ] }
  48         { CHAR: x [ hex-escape ] }
  49         [ escape swap ]
  50     } case ;
  51
  52 <PRIVATE
  53
  54 : (unescape-string) ( accum str i/f -- accum )
  55     { sbuf object object } declare
  56     [
  57         cut-slice [ append! ] dip
  58         rest-slice next-escape [ suffix! ] dip
  59         CHAR: \\ over index (unescape-string)
  60     ] [
  61         append!
  62     ] if* ;
  63
  64 PRIVATE>
  65
  66 : unescape-string ( str -- str' )
  67     CHAR: \\ over index [
  68         [ [ length <sbuf> ] keep ] dip (unescape-string)
  69     ] when* "" like ;
  70
  71 <PRIVATE
  72
  73 : (parse-string) ( accum str -- accum m )
  74     { sbuf slice } declare
  75     dup [ "\"\\" member? ] find [
  76         [ cut-slice [ append! ] dip rest-slice ] dip
  77         CHAR: " = [
  78             from>>
  79         ] [
  80             next-escape [ suffix! ] dip (parse-string)
  81         ] if
  82     ] [
  83         "Unterminated string" throw
  84     ] if* ;
  85
  86 PRIVATE>
  87
  88 : parse-string ( -- str )
  89     SBUF" " clone lexer get [
  90         swap tail-slice (parse-string) [ "" like ] dip
  91     ] change-lexer-column ;
  92
  93 <PRIVATE
  94
  95 : lexer-subseq ( i lexer -- before )
  96     { fixnum lexer } declare
  97     [ [ column>> ] [ line-text>> ] bi swapd subseq ]
  98     [ column<< ] 2bi ;
  99
 100 : rest-of-line ( lexer -- seq )
 101     { lexer } declare
 102     [ line-text>> ] [ column>> ] bi tail-slice ;
 103
 104 : current-char ( lexer -- ch/f )
 105     { lexer } declare
 106     [ column>> ] [ line-text>> ] bi ?nth ;
 107
 108 : advance-char ( lexer -- )
 109     { lexer } declare
 110     [ 1 + ] change-column drop ;
 111
 112 ERROR: escaped-char-expected ;
 113
 114 : next-char ( lexer -- ch )
 115     { lexer } declare
 116     dup still-parsing-line? [
 117         [ current-char ] [ advance-char ] bi
 118     ] [
 119         escaped-char-expected
 120     ] if ;
 121
 122 : lexer-head? ( lexer string -- ? )
 123     { lexer string } declare
 124     [ rest-of-line ] dip head? ;
 125
 126 : advance-lexer ( lexer n -- )
 127     { lexer fixnum } declare
 128     [ + ] curry change-column drop ;
 129
 130 : find-next-token ( lexer ch -- i elt )
 131     { lexer fixnum } declare
 132     [ [ column>> ] [ line-text>> ] bi ] dip
 133     CHAR: \ 2array [ member? ] curry find-from ;
 134
 135 : next-line% ( accum lexer -- )
 136     { sbuf lexer } declare
 137     [ rest-of-line swap push-all ]
 138     [ next-line CHAR: \n swap push ] 2bi ;
 139
 140 : take-double-quotes ( lexer -- string )
 141     { lexer } declare
 142     dup current-char CHAR: " = [
 143         dup [ column>> ] [ line-text>> ] bi
 144         [ CHAR: " = not ] find-from drop [
 145             over column>> - CHAR: " <repetition>
 146         ] [
 147             dup rest-of-line
 148         ] if*
 149         [ length advance-lexer ] keep
 150     ] [ drop f ] if ;
 151
 152 : end-string-parse ( accum lexer delimiter -- )
 153     { sbuf lexer string } declare
 154     length 3 = [
 155         take-double-quotes 3 tail-slice swap push-all
 156     ] [
 157         advance-char drop
 158     ] if ;
 159
 160 DEFER: (parse-multiline-string-until)
 161
 162 : parse-found-token ( accum lexer string i token -- )
 163     { sbuf lexer string fixnum fixnum } declare
 164     [ [ 2over ] dip swap lexer-subseq swap push-all ] dip
 165     CHAR: \ = [
 166         2over next-char swap push
 167         2over next-char swap push
 168         (parse-multiline-string-until)
 169     ] [
 170         2dup lexer-head? [
 171             end-string-parse
 172         ] [
 173             2over next-char swap push
 174             (parse-multiline-string-until)
 175         ] if
 176     ] if ;
 177
 178 : (parse-multiline-string-until) ( accum lexer string -- )
 179     { sbuf lexer fixnum } declare
 180     over still-parsing? [
 181         2dup first find-next-token [
 182             parse-found-token
 183         ] [
 184             drop 2over next-line%
 185             (parse-multiline-string-until)
 186         ] if*
 187     ] [
 188         throw-unexpected-eof
 189     ] if ;
 190
 191 PRIVATE>
 192
 193 : parse-multiline-string-until ( arg -- string )
 194     [ SBUF" " clone ] dip [
 195         [ lexer get ] dip (parse-multiline-string-until)
 196     ] curry keep unescape-string ;