#| Copyright 2024 Peter McGoron
 |
 | Licensed under the Apache License, Version 2.0 (the "License");
 |
 | you may not use this file except in compliance with the License.
 | You may obtain a copy of the License at
 |
 |     http://www.apache.org/licenses/LICENSE-2.0
 |
 | Unless required by applicable law or agreed to in writing, software
 | distributed under the License is distributed on an "AS IS" BASIS,
 | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
 | See the License for the specific language governing permissions and
 | limitations under the License.
 |#

(load "../mcgoron/srfi/61.sld")
(load "../market/string.sld")
(load "../market/blocks.sld")
(load "../market/default.sld")

(import (prefix (only (mcgoron srfi 64) factory set-verbosity!)
                mcgoron-test-)
        (srfi 64) (srfi 197) (srfi 117))
(import (market default) (market string) (market blocks))

(test-runner-factory mcgoron-test-factory)
(test-runner-current (test-runner-create))
(mcgoron-test-set-verbosity! '(fails group-stack))

;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Chained test predicates
;;; 
;;; These apply a test to `value` and return `value` afterwards, so that
;;; they can be chained in a `chain` expressions.

(define (test-assert-then name actual-procedure value)
  (test-assert name (actual-procedure value))
  value)

(define test-equal-then
  (case-lambda
    ((name expected actual)
     (test-equal name expected actual)
     actual)
    ((name expected actual-procedure value)
     (test-equal name expected (actual-procedure value))
     value)))

(define (test-length-then name expected lst)
  (test-equal name expected (length lst))
  lst)

;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Wrappers for commonly used test operations on nodes
;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (test-parse->document . arguments)
  (chain (apply parse->document arguments)
         (test-assert-then "document-node?"
                           document-node?
                           _)))

(define (test-node-list name expected node)
  (chain (node-children node)
         (test-assert-then "queue" list-queue? _)
         (list-queue-list _)
         (test-length-then name expected _)))

(define (test-child name procedure num lst)
  (chain (list-ref lst num)
         (test-assert-then name procedure _)))

(define (fork name arg procedure)
  (test-group name
    (procedure arg))
  arg)

(define-syntax with-test-chain
  (syntax-rules ()
    ((with-test-chain name chain-body ...)
     (test-group name (chain chain-body ...)))))

;;; ;;;;;;;;;;;;;;;;;;;;;;
;;; Paragraphs
;;; ;;;;;;;;;;;;;;;;;;;;;;;

(define (test-child-string name num expected lst)
  (test-group name
    (chain (test-child "xstring" xstring? num lst)
           (xstring->string _)
           (test-equal-then "text" expected _)))
  lst)

(define (test-paragraph-break name num lst)
  (test-child-string name num "\n" lst))

(test-group "paragraphs"
  (with-test-chain "single line"
    (test-parse->document "hello, world")
    (test-node-list "document children" 1 _)
    (test-child-string "text" 0 "hello, world\n" _))
  (with-test-chain "two lines"
    (test-parse->document "hello,")
    (test-parse->document "world" _)
    (test-node-list "document children" 1 _)
    (test-child-string "text" 0 "hello,\nworld\n" _))
  (with-test-chain "two paragraphs"
    (test-parse->document "hello")
    (test-parse->document "" _)
    (test-parse->document "world" _)
    (test-node-list "document children" 3 _)
    (test-child-string "first" 0 "hello\n" _)
    (test-paragraph-break "break" 1 _)
    (test-child-string "second" 2 "world\n" _)))

(test-group "block quotes"
  (with-test-chain "single line"
    (test-parse->document "> hello, world")
    (test-node-list "document node" 1 _)
    (test-child "block-quote?" block-quote? 0 _)
    (test-node-list "block children" 1 _)
    (test-child-string "text" 0 "hello, world\n" _))
  (with-test-chain "two lines"
    (test-parse->document "> hello,")
    (test-parse->document "> world" _)
    (test-node-list "document node" 1 _)
    (test-child "block-quote?" block-quote? 0 _)
    (test-node-list "quote children" 1 _)
    (test-child-string "text" 0 "hello,\nworld\n" _))
  (with-test-chain "multiple paragraphs in block quote"
    (test-parse->document "> hello")
    (test-parse->document "> " _)
    (test-parse->document "> world" _)
    (test-node-list "document node" 1 _)
    (test-child "block-quote?" block-quote? 0 _)
    (test-node-list "quote node" 3 _)
    (test-child-string "first" 0 "hello\n" _)
    (test-paragraph-break "break" 1 _)
    (test-child-string "second" 2 "world\n" _))
  (with-test-chain "interrupted by paragraph break"
    (test-parse->document "> hello,")
    (test-parse->document "" _)
    (test-parse->document "world" _)
    (test-node-list "document node" 3 _)
    (fork
     "block quote"
     _
     (chain-lambda (test-child "block-quote?" block-quote? 0 _)
                   (test-node-list "quote children" 1 _)
                   (test-child-string "quote" 0 "hello,\n" _)))
    (test-paragraph-break "break" 1 _)
    (test-child-string "paragraph" 2 "world\n" _))
  (with-test-chain "interrupted"
    (test-parse->document "> hello, world")
    (test-parse->document "outside of a block quote" _)
    (test-node-list "document children" 2 _)
    (fork
     "block quote"
     _
     (chain-lambda (test-child "block-quote?" block-quote? 0 _)
                   (test-node-list "quote children" 1 _)
                   (test-child-string "quote" 0 "hello, world\n" _)))
    (test-child-string "paragraph" 1 "outside of a block quote\n" _))
  (with-test-chain "two nested with spaces"
    (test-parse->document "> > hello, world")
    (test-parse->document "> > continuing nested" _)
    (test-parse->document "> outside of the block quote" _)
    (test-node-list "document children" 1 _)
    (test-child "top block-quote?" block-quote? 0 _)
    (test-node-list "top block quote children" 2 _)
    (fork
     "nested quote"
     _
     (chain-lambda (test-child "nested quote" block-quote? 0 _)
                   (test-node-list "nested quote children" 1 _)
                   (test-child-string "quote" 0 "hello, world\ncontinuing nested\n" _)))
    (test-child-string "inside quote" 1 "outside of the block quote\n" _))
  (with-test-chain "two nested without spaces"
    (test-parse->document ">> hello, world")
    (test-parse->document ">> continuing nested" _)
    (test-parse->document "> at first level" _)
    (test-parse->document "> continuing first level" _)
    (test-node-list "document children" 1 _)
    (test-child "block-quote?" block-quote? 0 _)
    (test-node-list "block quote children" 2 _)
    (fork
     "nested block quote"
     _
     (chain-lambda (test-child "nested block quote" block-quote? 0 _)
                   (test-node-list "nested block quote children" 1 _)
                   (test-child-string "nested" 0 "hello, world\ncontinuing nested\n" _)))
    (test-child-string "first level" 1 "at first level\ncontinuing first level\n" _)))

(test-group "atx headings"
  (with-test-chain "heading 1"
    (test-parse->document "# hello")
    (test-node-list "document children" 1 _)
    (test-child "atx-heading?" atx-heading? 0 _)
    (test-equal-then "indent"
                     1
                     atx-heading-indent
                     _)
    (test-node-list "heading children" 1 _)
    (test-child-string "xstring?" 0 "hello" _))
  (with-test-chain "heading 6"
    (test-parse->document "###### hello")
    (test-node-list "document children" 1 _)
    (test-child "atx-heading?" atx-heading? 0 _)
    (test-equal-then "indent" 6 atx-heading-indent _)
    (test-node-list "heading children" 1 _)
    (test-child-string "xstring?" 0 "hello" _))
  (with-test-chain "heading followed by paragraph"
    (test-parse->document "## hello, ")
    (test-parse->document "world" _)
    (test-parse->document "## another heading" _)
    (test-node-list "document children" 3 _)
    (fork
     "atx heading 1"
     _
     (chain-lambda (test-child "atx-heading?" atx-heading? 0 _)
                   (test-equal-then "indent" 2 atx-heading-indent _)
                   (test-node-list "children" 1 _)
                   (test-child-string "xstring?" 0 "hello, " _)))
    (test-child-string "paragraph" 1 "world\n" _)
    (fork
     "atx heading 2"
     _
     (chain-lambda (test-child "atx-heading?" atx-heading? 2 _)
                   (test-equal-then "indent" 2 atx-heading-indent _)
                   (test-node-list "children" 1 _)
                   (test-child-string "xstring?" 0 "another heading" _))))
  (with-test-chain "heading inside block quote"
    (test-parse->document "> # nested heading")
    (test-parse->document "> text inside quote" _)
    (test-parse->document "### outside of quote" _)
    (test-node-list "document children" 2 _)
    (fork
     "block quote"
     _
     (chain-lambda (test-child "block-quote?" block-quote? 0 _)
                   (test-node-list "block quote children" 2 _)
                   (fork
                    "atx heading"
                    _
                    (chain-lambda (test-child "atx-heading?" atx-heading? 0 _)
                                  (test-equal-then "indent" 1 atx-heading-indent _)
                                  (test-node-list "children" 1 _)
                                  (test-child-string "xstring?" 0 "nested heading" _)))
                   (test-child-string "xstring?" 1 "text inside quote\n" _)))
    (fork
     "heading outside of quote"
     _
     (chain-lambda (test-child "atx-heading?" atx-heading? 1 _)
                   (test-equal-then "indent" 3 atx-heading-indent _)
                   (test-node-list "children" 1 _)
                   (test-child-string "xstring?" 0 "outside of quote" _)))))

(test-group "code blocks"
  (define (test/string name prepend)
    (with-test-chain name
      (test-parse->document (string-append prepend "(procedure? call/cc)"))
      (test-node-list "document children" 1 _)
      (test-child "code-block?" code-block? 0 _)
      (test-node-list "block children" 1 _)
      (test-child-string "xstring?" 0 "(procedure? call/cc)\n" _)))
  (test/string "single line, 4 spaces" "    ")
  (test/string "single line, tab" "\t")
  (with-test-chain "multiple lines, mixing"
    (test-parse->document "    (lambda (x)")
    (test-parse->document "\t  x)" _)
    (test-node-list "document children" 1 _)
    (test-child "code-block?" code-block? 0 _)
    (test-node-list "block children" 1 _)
    (test-child-string "xstring?" 0 "(lambda (x)\n  x)\n" _))
  (with-test-chain "no quotes in code blocks"
    (test-parse->document "    > not a block")
    (test-node-list "document children" 1 _)
    (test-child "code-block?" code-block? 0 _)
    (test-node-list "block children" 1 _)
    (test-child-string "xstring?" 0 "> not a block\n" _))
  (with-test-chain "code block in quotes"
    (test-parse->document ">     quoted code")
    (test-node-list "document children" 1 _)
    (test-child "block-quote?" block-quote? 0 _)
    (test-node-list "quote children" 1 _)
    (test-child "code-block?" code-block? 0 _)
    (test-node-list "code block children" 1 _)
    (test-child-string "xstring?" 0 "quoted code\n" _))
  (with-test-chain "code block with empty lines"
    (test-parse->document "    code")
    (test-parse->document "    " _)
    (test-parse->document "    " _)
    (test-parse->document "    block" _)
    (test-node-list "document children" 1 _)
    (test-child "code block" code-block? 0 _)
    (test-node-list "code block children" 4 _)
    (test-child-string "first" 0 "code\n" _)
    (test-paragraph-break "second" 1 _)
    (test-paragraph-break "third" 2 _)
    (test-child-string "fourth" 3 "block\n" _)))

(test-group "unordered lists"
  (with-test-chain "one element"
    (test-parse->document "* hello, world")
    (test-node-list "document children" 1 _)
    (test-child "unordered-list-item?" unordered-list-item? 0 _)
    (test-node-list "list children" 1 _)
    (test-child-string "xstring?" 0 "hello, world\n" _))
  (with-test-chain "one element continued"
    (test-parse->document "* hello,")
    (test-parse->document "  world" _)
    (test-node-list "document children" 1 _)
    (test-child "list item" unordered-list-item? 0 _)
    (test-node-list "list children" 1 _)
    (test-child-string "xstring?" 0 "hello,\nworld\n" _))
  (with-test-chain "one element with indentation"
    (test-parse->document "* hello, world")
    (test-parse->document "  " _)
    (test-parse->document "  second paragraph" _)
    (test-node-list "document children" 1 _)
    (test-child "list item" unordered-list-item? 0 _)
    (test-node-list "list children" 3 _)
    (test-child-string "first" 0 "hello, world\n" _)
    (test-paragraph-break "break" 1 _)
    (test-child-string "second" 2 "second paragraph\n" _))
  (with-test-chain "one element w/o indentation"
    (test-parse->document "* hello, world")
    (test-parse->document "" _)
    (test-parse->document "  second paragraph" _)
    (test-node-list "document children" 1 _)
    (test-child "list item" unordered-list-item? 0 _)
    (test-node-list "list children" 3 _)
    (test-child-string "first" 0 "hello, world\n" _)
    (test-paragraph-break "break" 1 _)
    (test-child-string "first" 2 "second paragraph\n" _))
  (with-test-chain "one element interrupted"
    (test-parse->document "* hello,")
    (test-parse->document "world" _)
    (test-node-list "document children" 2 _)
    (fork
     "list item"
     _
     (chain-lambda (test-child "list item" unordered-list-item? 0 _)
                   (test-node-list "items" 1 _)
                   (test-child-string "xstring?" 0 "hello,\n" _)))
    (test-child-string "paragraph" 1 "world\n" _))
  (with-test-chain "one element interrupted with empty line"
    (test-parse->document "* hello,")
    (test-parse->document "" _)
    (test-parse->document "world" _)
    (test-node-list "document children" 3 _)
    (fork
     "list item"
     _
     (chain-lambda (test-child "list item" unordered-list-item? 0 _)
                   (test-node-list "items" 1 _)
                   (test-child-string "xstring?" 0 "hello,\n" _)))
    (test-paragraph-break "break" 1 _)
    (test-child-string "paragraph" 2 "world\n" _))
  (with-test-chain "multiple list elements"
    (test-parse->document "* h")
    (test-parse->document "  el" _)
    (test-parse->document "* lo" _)
    (test-node-list "document children" 2 _)
    (fork
     "first list item"
     _
     (chain-lambda (test-child "list item" unordered-list-item? 0 _)
                   (test-node-list "items" 1 _)
                   (test-child-string "xstring?" 0 "h\nel\n" _)))
    (fork
     "second list item"
     _
     (chain-lambda (test-child "list item" unordered-list-item? 1 _)
                   (test-node-list "items" 1 _)
                   (test-child-string "xstring?" 0 "lo\n" _))))
  (with-test-chain "nested list elements"
    (test-parse->document "* hello")
    (test-parse->document "  * world" _)
    (test-parse->document "" _)
    (test-parse->document "  " _)
    (test-parse->document "    foo" _)
    (test-parse->document "  bar" _)
    (test-node-list "document children" 1 _)
    (test-child "list item" unordered-list-item? 0 _)
    (test-node-list "main item children" 3 _)
    (test-child-string "first" 0 "hello\n" _)
    (fork
     "nested list item"
     _
     (chain-lambda (test-child "list item" unordered-list-item? 1 _)
                   (test-node-list "children" 4 _)
                   (test-child-string "first" 0 "world\n" _)
                   (test-paragraph-break "break 1" 1 _)
                   (test-paragraph-break "break 2" 2 _)
                   (test-child-string "first" 3 "foo\n" _)))
    (test-child-string "paragraph" 2 "bar\n" _)))

(test-group "thematic breaks"
  (define (test-single-thematic-break name data)
    (with-test-chain name
      (test-parse->document data)
      (test-node-list "document children" 1 _)
      (test-child "thematic break" thematic-break? 0 _)))
  (define (test-as-code-block name data)
    (with-test-chain name
      (test-parse->document (string-append "\t" data))
      (test-node-list "document-children" 1 _)
      (test-child "code block" code-block? 0 _)
      (test-node-list "block list" 1 _)
      (test-child-string "xstring?" 0 (string-append data "\n") _)))
  (define (test-as-paragraph name data)
    (with-test-chain name
      (test-parse->document data)
      (test-node-list "document children" 1 _)
      (test-child-string "xstring?" 0 (string-append data "\n") _)))
  (test-single-thematic-break "***" "***")
  (test-single-thematic-break " ***" " ***")
  (test-single-thematic-break "  ***" "  ***")
  (test-single-thematic-break "   ***" "   ***")
  (test-single-thematic-break "* * *" "* * *")
  (test-single-thematic-break "*********" "*********")
  (test-as-code-block "code block ***" "***")
  (test-as-paragraph "**" "**")
  (test-as-paragraph "***a***" "***a***")
  (test-single-thematic-break "-" "---")
  (test-single-thematic-break " -" " ---")
  (test-single-thematic-break "  -" "  ---")
  (test-single-thematic-break "   -" "   ---")
  (test-as-code-block "code block ---" "---")
  (test-as-paragraph "--" "--")
  (test-as-paragraph "--" "--")
  (test-as-paragraph "---a" "---a")
  (test-as-paragraph "   -----a------" "   -----a------")
  (test-single-thematic-break "- - -" "- - -")
  (test-single-thematic-break "---------" "---------")
  (test-single-thematic-break "_" "___")
  (test-single-thematic-break " _" " ___")
  (test-single-thematic-break "  _" "  ___")
  (test-single-thematic-break "   _" "   ___")
  (test-as-code-block "code block ___" "___")
  (test-as-paragraph "__" "__")
  (test-single-thematic-break "_ _ _" "_ _ _")
  (test-single-thematic-break "_________" "_________")
  (test-as-paragraph "__" "__")
  (test-as-paragraph "___a" "___a")
  (test-as-paragraph "   _____a______" "   _____a______")
  (with-test-chain "break takes precedence"
    (test-parse->document "* hello")
    (test-parse->document "* * *" _)
    (test-parse->document "* world" _)
    (test-node-list "document children" 3 _)
    (fork
     "first list item"
     _
     (chain-lambda (test-child "unordered list?" unordered-list-item? 0 _)
                   (test-node-list "children" 1 _)
                   (test-child-string "xstring?" 0 "hello\n")))
    (fork
     "thematic break"
     _
     (chain-lambda (test-child "thematic break" thematic-break? 1 _)))
    (fork
     "third list item"
     _
     (chain-lambda (test-child "unordered list?" unordered-list-item? 2 _)
                   (test-node-list "children" 1 "world\n" _))))
  (with-test-chain "interrupt paragraph"
    (test-parse->document "hello")
    (test-parse->document "***" _)
    (test-parse->document "world" _)
    (test-node-list "document children" 3 _)
    (test-child-string "string" 0 "hello\n" _)
    (fork
     "break"
     _
     (chain-lambda (test-child "thematic break" thematic-break? 1 _)))
    (test-child-string "string" 2 "world\n" _)))