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 lexer make
   4 math math.parser namespaces sequences splitting strings ;
   5 IN: strings.parser
   6
   7 ERROR: bad-escape char ;
   8
   9 : escape ( escape -- ch )
  10     H{
  11         { CHAR: a  CHAR: \a }
  12         { CHAR: e  CHAR: \e }
  13         { CHAR: n  CHAR: \n }
  14         { CHAR: r  CHAR: \r }
  15         { CHAR: t  CHAR: \t }
  16         { CHAR: s  CHAR: \s }
  17         { CHAR: \s CHAR: \s }
  18         { CHAR: 0  CHAR: \0 }
  19         { CHAR: \\ CHAR: \\ }
  20         { CHAR: \" CHAR: \" }
  21     } ?at [ bad-escape ] unless ;
  22
  23 SYMBOL: name>char-hook
  24
  25 name>char-hook [
  26     [ "Unicode support not available" throw ]
  27 ] initialize
  28
  29 : hex-escape ( str -- ch str' )
  30     2 cut-slice [ hex> ] dip ;
  31
  32 : unicode-escape ( str -- ch str' )
  33     "{" ?head-slice [
  34         CHAR: } over index cut-slice
  35         [ >string name>char-hook get call( name -- char ) ] dip
  36         rest-slice
  37     ] [
  38         6 cut-slice [ hex> ] dip
  39     ] if ;
  40
  41 : next-escape ( str -- ch str' )
  42     dup first {
  43         { CHAR: u [ 1 tail-slice unicode-escape ] }
  44         { CHAR: x [ 1 tail-slice hex-escape ] }
  45         [ drop unclip-slice escape swap ]
  46     } case ;
  47
  48 : (unescape-string) ( str -- )
  49     CHAR: \\ over index dup [
  50         cut-slice [ % ] dip rest-slice
  51         next-escape [ , ] dip
  52         (unescape-string)
  53     ] [
  54         drop %
  55     ] if ;
  56
  57 : unescape-string ( str -- str' )
  58     [ (unescape-string) ] "" make ;
  59
  60 : (parse-string) ( str -- m )
  61     dup [ "\"\\" member? ] find dup [
  62         [ cut-slice [ % ] dip rest-slice ] dip
  63         CHAR: " = [
  64             from>>
  65         ] [
  66             next-escape [ , ] dip (parse-string)
  67         ] if
  68     ] [
  69         "Unterminated string" throw
  70     ] if ;
  71
  72 : parse-string ( -- str )
  73     lexer get [
  74         [ swap tail-slice (parse-string) ] "" make swap
  75     ] change-lexer-column ;
  76
  77 <PRIVATE
  78
  79 : lexer-subseq ( i -- before )
  80     [
  81         [
  82             lexer get
  83             [ column>> ] [ line-text>> ] bi
  84         ] dip swap subseq
  85     ] [
  86         lexer get column<<
  87     ] bi ;
  88
  89 : rest-of-line ( lexer -- seq )
  90     [ line-text>> ] [ column>> ] bi tail-slice ;
  91
  92 : current-char ( lexer -- ch/f )
  93     [ column>> ] [ line-text>> ] bi ?nth ;
  94
  95 : advance-char ( lexer -- )
  96     [ 1 + ] change-column drop ;
  97
  98 ERROR: escaped-char-expected ;
  99
 100 : next-char ( lexer -- ch )
 101     dup still-parsing-line? [
 102         [ current-char ] [ advance-char ] bi
 103     ] [
 104         escaped-char-expected
 105     ] if ;
 106
 107 : lexer-head? ( string -- ? )
 108     [ lexer get rest-of-line ] 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 ( string i 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 ;