#lang scheme
(require syntax-color/scribble-lexer)

(define in (open-input-string "@|x #|10|#| @me[1 2 #| comment |# ]{10}"))

(define (color str)
  (let ([in (open-input-string str)])
    (let loop ([mode #f])
      (let-values ([(lexeme type paren start end backup mode) (scribble-inside-lexer in 0 mode)])
        (if (eq? type 'eof)
            null
            (cons (list start end type backup)
                  (loop mode)))))))

(define (test* str len-val line)
  (let ([v (color str)]
        [val (let loop ([pos 1][l len-val])
               (if (null? l)
                   null
                   (cons (list pos (+ pos (caar l)) (cadar l)
                               (if (null? (cddar l))
                                   0
                                   (caddar l)))
                         (loop (+ (+ pos (caar l))) (cdr l)))))])
    (unless (equal? v val)
      (printf "FAILED, line ~s\n" line)
      (printf " result\n")
      (pretty-print v)
      (printf " is not expected\n")
      (pretty-print val)
      (printf "\n"))))

(define-syntax-rule (test str len-val)
  (test* str len-val (syntax-line #'str)))

(test "x" '((1 string)))
(test "x{}" '((3 string)))
(test "@x" '((1 parenthesis)
             (1 symbol)))

(test "@x str" '((1 parenthesis)
                 (1 symbol)
                 (4 string)))

(test "@x[] str" '((1 parenthesis)
                   (1 symbol)
                   (1 parenthesis)
                   (1 parenthesis)
                   (4 string)))

(test "@x[z] str" '((1 parenthesis)
                    (1 symbol)
                    (1 parenthesis)
                    (1 symbol)
                    (1 parenthesis)
                    (4 string)))

(test "@x[z +1.5] str" '((1 parenthesis)
                         (1 symbol)
                         (1 parenthesis)
                         (1 symbol)
                         (1 white-space)
                         (4 constant)
                         (1 parenthesis)
                         (4 string)))

(test "@x[z @w{10}] str" '((1 parenthesis)
                           (1 symbol) ; x
                           (1 parenthesis)
                           (1 symbol) ; z
                           (1 white-space)
                           (1 parenthesis)
                           (1 symbol) ; w
                           (1 parenthesis)
                           (2 string)
                           (1 parenthesis)
                           (1 parenthesis)
                           (4 string)))

(test "@x[a@b]{a}{b}" '((1 parenthesis)
                        (1 symbol)
                        (1 parenthesis)
                        (3 symbol)
                        (1 parenthesis)
                        (1 parenthesis)
                        (1 string)
                        (1 parenthesis)
                        (3 string)))
(test "@x{{}}" '((1 parenthesis)
                 (1 symbol)
                 (1 parenthesis)
                 (1 parenthesis) ; {
                 (1 parenthesis) ; }
                 (1 parenthesis)))

(test "@|x|str" '((2 parenthesis)
                  (1 symbol 2)
                  (1 parenthesis 3)
                  (3 string)))
(test "@|x #|ok|#|str" '((2 parenthesis)
                         (1 symbol 2)
                         (1 white-space 3)
                         (6 comment)
                         (1 parenthesis)
                         (3 string)))
(test "@| x ; c\n| str" '((2 parenthesis)
                          (1 white-space 2)
                          (1 symbol)
                          (1 white-space)
                          (3 comment)
                          (2 parenthesis)
                          (4 string)))
(test "@|(a|b|)|str" '((2 parenthesis)
                       (1 parenthesis 2)
                       (4 symbol 3)
                       (1 parenthesis 7)
                       (1 parenthesis 8)
                       (3 string)))

(test "@#|bad|#x str" '((1 parenthesis)
                        (7 error)
                        (1 symbol)
                        (4 string)))
(test "@@x" '((1 parenthesis)
              (1 parenthesis)
              (1 symbol)))
(test "@|@x|z" '((2 parenthesis)
                 (1 parenthesis 2)
                 (1 symbol)
                 (1 parenthesis)
                 (1 string)))
(test "@@x[1 2][3]" '((1 parenthesis)
                      (1 parenthesis)
                      (1 symbol)
                      (1 parenthesis)
                      (1 constant)
                      (1 white-space)
                      (1 constant)
                      (1 parenthesis)
                      (1 parenthesis)
                      (1 constant)
                      (1 parenthesis)))

(test "@{1 2}" '((2 parenthesis)
                 (3 string)
                 (1 parenthesis)))
(test "@|=={1 2}==|" '((5 parenthesis)
                       (3 string)
                       (4 parenthesis)))
(test "@'{1 2}" '((1 parenthesis)
                  (1 constant)
                  (1 parenthesis)
                  (3 string)
                  (1 parenthesis)))
(test "@',#,#`|>>{1 2}<<|" '((1 parenthesis)
                             (1 constant) ; ,
                             (1 other)    ; ,
                             (2 other)    ; #,
                             (2 constant) ; #`
                             (4 parenthesis)
                             (3 string)
                             (4 parenthesis)))

(test "@x|{10}|" '((1 parenthesis)
                   (1 symbol)
                   (2 parenthesis)
                   (2 string)
                   (2 parenthesis)))
(test "@x|{@q}|" '((1 parenthesis)
                   (1 symbol)
                   (2 parenthesis)
                   (2 string)
                   (2 parenthesis)))
(test "@x|!!{@q}!!|" '((1 parenthesis)
                       (1 symbol)
                       (4 parenthesis)
                       (2 string)
                       (4 parenthesis)))
(test "@x|(({@q}))|" '((1 parenthesis)
                       (1 symbol)
                       (4 parenthesis)
                       (2 string)
                       (4 parenthesis)))
(test "@x|<<{a|<<@a[10]}>>|" '((1 parenthesis)
                               (1 symbol)
                               (4 parenthesis)
                               (1 string)
                               (4 parenthesis)
                               (1 symbol)
                               (1 parenthesis)
                               (2 constant)
                               (1 parenthesis)
                               (4 parenthesis)))
(test "@x|{ |{ } }|}|" '((1 parenthesis)
                         (1 symbol)
                         (2 parenthesis)
                         (1 string)
                         (2 parenthesis) ; |{
                         (3 string)
                         (2 parenthesis) ; }|
                         (2 parenthesis)))

(test "@`',@foo{blah}" '((1 parenthesis)
                         (1 constant) ; `
                         (1 constant) ; '
                         (2 other)    ; ,@
                         (3 symbol)
                         (1 parenthesis)
                         (4 string)
                         (1 parenthesis)))

(test "@; 1" '((4 comment)))
(test "@; 1\nv" '((4 comment)
                  (1 white-space)
                  (1 string)))
(test "@;{1}v" '((2 comment)
                 (1 parenthesis)
                 (1 string)
                 (1 parenthesis)
                 (1 string)))
(test "@;|{1 }} }|v" '((2 comment)
                       (2 parenthesis)
                       (5 string)
                       (2 parenthesis)
                       (1 string)))

(test "a\n  b" '((1 string)
                 (3 white-space)
                 (1 string)))
(test "@item{A\nB}" '((1 parenthesis)
                      (4 symbol)
                      (1 parenthesis)
                      (1 string)
                      (1 white-space)
                      (1 string)
                      (1 parenthesis)))

(test "@|()|})|" '((2 parenthesis)
                   (1 parenthesis 2)
                   (1 parenthesis 3)
                   (1 parenthesis 4)
                   (3 string)))