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