 ! Copyright (C) 2008, 2009 Slava Pestov, Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays assocs combinators kernel lexer make
-math math.parser namespaces sequences splitting strings ;
+USING: accessors arrays assocs combinators kernel lexer
+math math.parser namespaces sbufs sequences splitting strings ;
 IN: strings.parser
 
 ERROR: bad-escape char ;

        escaped-char-expected
    ] if ;

: lexer-head? ( string -- ? )
    [ lexer get rest-of-line ] dip head? ;

: advance-lexer ( n -- )
    [ lexer get ] dip [ + ] curry change-column drop ; inline

: find-next-token ( ch -- i elt )
    CHAR: \ 2array
    [ lexer get [ column>> ] [ line-text>> ] bi ] dip
    [ member? ] curry find-from ;

: next-line% ( lexer -- )
    [ rest-of-line % ]
    [ next-line "\n" % ] bi ;

: take-double-quotes ( -- string )
    lexer get dup current-char CHAR: " = [
        [ ] [ column>> ] [ line-text>> ] tri
        [ CHAR: " = not ] find-from drop [
            swap column>> - CHAR: " <repetition>
        ] [
            rest-of-line
        ] if*
    ] [
        drop f
    ] if dup length advance-lexer ;

: end-string-parse ( delimiter -- )
    length 3 = [
        take-double-quotes 3 tail %
    ] [
        lexer get advance-char
    ] if ;

DEFER: (parse-multiline-string)

: parse-found-token ( string i token -- )
    [ lexer-subseq % ] dip
    CHAR: \ = [
        lexer get [ next-char , ] [ next-char , ] bi (parse-multiline-string)
    ] [
        dup lexer-head? [
            end-string-parse
        ] [
            lexer get next-char , (parse-multiline-string)
        ] if
    ] if ;

ERROR: trailing-characters string ;

: (parse-multiline-string) ( string -- )
    lexer get still-parsing? [
        dup first find-next-token [
            parse-found-token
        ] [
            drop lexer get next-line%
            (parse-multiline-string)
        ] if*
    ] [
        throw-unexpected-eof
    ] if ;

PRIVATE>

: parse-multiline-string ( -- string )
    lexer get rest-of-line "\"\"" head? [
        lexer get [ 2 + ] change-column drop
        "\"\"\""
    ] [
        "\""
    ] if [ (parse-multiline-string) ] "" make unescape-string ;

        [ drop unclip-slice escape swap ]
    } case ;

<PRIVATE

: (unescape-string) ( accum str i/f -- accum )
    [
        cut-slice [ over push-all ] dip
        rest-slice next-escape [ over push ] dip
        CHAR: \\ over index (unescape-string)
    ] [
        over push-all
    ] if* ; inline recursive

PRIVATE>

: unescape-string ( str -- str' )
    CHAR: \\ over index [
        [ [ length <sbuf> ] keep ] dip (unescape-string)
    ] when* "" like ;

<PRIVATE

: (parse-string) ( accum str -- accum m )
    dup [ "\"\\" member? ] find [
        [ cut-slice [ over push-all ] dip rest-slice ] dip
        CHAR: " = [
            from>>
        ] [
            next-escape [ over push ] dip (parse-string)
        ] if
    ] [
        "Unterminated string" throw
    ] if* ; inline recursive

PRIVATE>

: parse-string ( -- str )
    lexer get [
        [ SBUF" " clone ] 2dip swap tail-slice
        (parse-string) [ "" like ] dip
    ] change-lexer-column ;

<PRIVATE

: lexer-subseq ( i lexer -- before )
    [ [ column>> ] [ line-text>> ] bi swapd subseq ]
    [ column<< ] 2bi ;

: rest-of-line ( lexer -- seq )
    [ line-text>> ] [ column>> ] bi tail-slice ;
