 ! 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 ;

        [ drop unclip-slice escape swap ]
    } case ;

: (unescape-string) ( str -- )
    CHAR: \\ over index dup [
        cut-slice [ % ] dip rest-slice
        next-escape [ , ] dip
        (unescape-string)
    ] [
        drop %
    ] if ;

: unescape-string ( str -- str' )
    [ (unescape-string) ] "" make ;

: (parse-string) ( str -- m )
    dup [ "\"\\" member? ] find dup [
        [ cut-slice [ % ] dip rest-slice ] dip
        CHAR: " = [
            from>>
        ] [
            next-escape [ , ] dip (parse-string)
        ] if
    ] [
        "Unterminated string" throw
    ] if ;

: parse-string ( -- str )
    lexer get [
        [ swap tail-slice (parse-string) ] "" make swap
    ] change-lexer-column ;

<PRIVATE

: lexer-subseq ( i -- before )
    [
        [
            lexer get
            [ column>> ] [ line-text>> ] bi
        ] dip swap subseq
    ] [
        lexer get column<<
    ] bi ;

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

        escaped-char-expected
    ] if ;

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

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

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

: next-line% ( accum lexer -- )
    [ rest-of-line swap push-all ]
    [ next-line CHAR: \n swap push ] 2bi ; inline

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

: end-string-parse ( accum lexer delimiter -- )
    length 3 = [
        take-double-quotes 3 tail-slice swap push-all
    ] [
        advance-char drop
    ] if ; inline

DEFER: (parse-multiline-string)

: parse-found-token ( accum lexer string i token -- )
    [ [ 2over ] dip swap lexer-subseq swap push-all ] dip
    CHAR: \ = [
        2over next-char swap push
        2over next-char swap push
        (parse-multiline-string)
    ] [
        2dup lexer-head? [
            end-string-parse
        ] [
            2over next-char swap push
            (parse-multiline-string)
        ] if
    ] if ; inline recursive

ERROR: trailing-characters string ;

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

PRIVATE>

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