;; This file is part of Beastie <https://purl.org/nxg/dist/beastie>
;; SPDX-FileCopyrightText: 2023 Norman Gray <https://nxg.me.uk>
;; SPDX-License-Identifier: BSD-2-Clause

(module "s7unit.scm" 'markdown)

(print-warning 'push #f)
;; (define parse-markdown-string
;;   (let ((f parse-markdown-string))
;;     (lambda (s)
;;       (printf "~a~%...~%" s)
;;       (f s))))

(test-suite
 "markdown various"

 ;; basics: paragraphs, sectioning and lists
 (let ((md (parse-markdown-string
            (string-join '("A simple _Markdown_ file"
                           "======================"
                           ""
                           "Paragraph 1."
                           "Second sentence."
                           ""
                           "  * UL item 1."
                           "  * UL item 2."
                           "    Sentence 2.2."
                           "  * UL item 3."
                           "    Sentence 3.2."
                           ""
                           "Now a one-item list:"
                           "  * Hello"
                           ""
                           "An ordered list:"
                           ""
                           "1. OL item 1."
                           ""
                           "2. OL item 2."
                           "     Sentence 2.2."
                           ""
                           "     And a further paragraph in item 2." ; 5-space indent shouldn't mess things up
                           ""
                           "3. OL item 3."
                           "     Sentence 3.2."
                           ""
                           "1\\. This is not a list"
                           ""
                           "Another section  " ;trailing blanks
                           "---------------"
                           ""
                           "Text preceding"
                           ""
                           "    Indented text"
                           "    More indented text"
                           ""
                           "# H1 line  " ;trailing blanks
                           ""
                           "    Single pre"
                           ""
                           "## H2 line #" ;trailing hash
                           ""
                           "    Indented1"
                           "    Indented2"
                           ""
                           "    Indented3"
                           ""
                           "### H3 line"
                           ""
                           "############### H6 line#######"
                           ""
                           "Text"
                           ""
                           "##  ")       ; shouldn't be recognised as a heading
                         "\n"
                         'suffix))))
   (assert-equal md
                 '(div
                   (h1 (a ((name "a-simple-markdown-file"))
                          "A simple " (em "Markdown") " file"))
                   (p "Paragraph 1. Second sentence.")
                   (ul (li "UL item 1.")
                       (li "UL item 2. Sentence 2.2.")
                       (li "UL item 3. Sentence 3.2."))
                   (p "Now a one-item list:")
                   (ul (li "Hello"))
                   (p "An ordered list:")
                   (ol (li (p "OL item 1."))
                       (li (p "OL item 2.  Sentence 2.2.") ;we don't care about the extra space
                           (p "And a further paragraph in item 2."))
                       (li (p "OL item 3.  Sentence 3.2.")))
                   (p "1" "." " This is not a list")
                   (h2 (a ((name "another-section")) "Another section"))
                   (p "Text preceding")
                   (pre "Indented text\nMore indented text")
                   (h1 (a ((name "h1-line")) "H1 line"))
                   (pre "Single pre")
                   (h2 (a ((name "h2-line")) "H2 line"))
                   (pre "Indented1\nIndented2\n\nIndented3")
                   (h3 (a ((name "h3-line")) "H3 line"))
                   (h6 (a ((name "h6-line")) "H6 line"))
                   (p "Text")
                   (p "##")))
   ;; there's no need to test xexpr-write/xhtml here
   )

 ;; tabs in certain places
 (assert-equal (parse-markdown-string
                #"""
List

  *    multiple spaces
        and space indent

    Item 1 para 2
  *	tab
	and tab indent

	Item 2 para 2 with tab indent

Code block

    with spaces

and

	with tab

""")
               '(div
                 (p "List")
                 (ul
                  (li
                   (p "multiple spaces     and space indent")
                   (p "Item 1 para 2"))
                  (li
                   (p "tab and tab indent")
                   (p "Item 2 para 2 with tab indent")))
                 (p "Code block")
                 (pre "with spaces")
                 (p "and")
                 (pre "with tab")))

 ;;;; Lists

 ;; Testing the internal structure of lists.  List items can run over
 ;; multiple lines, and don't need to be indented.
 (let ((md (parse-markdown-string #"""This is text.
More text.

* Item, paragraph one.

    Item one, continuation paragraph.

    Item one, third paragraph.
Which runs over
multiple lines.

  * A further item.
    With a second line
and a third.

Next para.""")
           ))
   (assert-equal md
                 '(div
                   (p "This is text. More text.")
                   (ul (li (p "Item, paragraph one.")
                           (p "Item one, continuation paragraph.")
                           (p "Item one, third paragraph. Which runs over multiple lines."))
                       (li (p "A further item. With a second line and a third.")))
                   (p "Next para."))))

 ;; sublists
 (let ((md (parse-markdown-string
            #"""Paragraph 1.
Second sentence.

  * UL item 1.
  * UL item 2.
    Sentence 2.2.
    - sub1
    - sub2
  * UL item 3.
    Sentence 3.2.

Now a one-item list:
  + Hello1

...with a leading blank line:

  + Hello2

An ordered list, indented with tabs:

1. OL item 1, with UL sublist.
    - OL1 sub1
    + OL1 sub2

2. OL item 2, with spaced OL sublist.

	1. OL2 sub1

	1. OL2 sub2

1. OL item 3""")))
   (assert-equal md
                 '(div
                   (p "Paragraph 1. Second sentence.")
                   (ul (li "UL item 1.")
                       (li "UL item 2. Sentence 2.2."
                           (ul (li "sub1")
                               (li "sub2")))
                       (li "UL item 3. Sentence 3.2."))
                   (p "Now a one-item list:")
                   (ul (li "Hello1"))
                   (p "...with a leading blank line:")
                   (ul (li "Hello2"))
                   (p "An ordered list, indented with tabs:")
                   (ol (li (p "OL item 1, with UL sublist.")
                           (ul (li "OL1 sub1")
                               (li "OL1 sub2")))
                       (li (p "OL item 2, with spaced OL sublist.")
                           (ol (li (p "OL2 sub1"))
                               (li (p "OL2 sub2"))))
                       (li (p "OL item 3"))))))

 ;; indented code
 (assert-equal (parse-markdown-string
                #"""
Para 1

    Simple

Para 2, sexp

    (div
      (p "Content")
      ...)

Para 3

    Various
      indentation
        levels
          up to
            this many

Para 4
""")
               '(div (p "Para 1")
                     (pre "Simple")
                     (p "Para 2, sexp")
                     (pre "(div\n  (p \"Content\")\n  ...)")
                     (p "Para 3")
                     (pre "Various\n  indentation\n    levels\n      up to\n        this many")
                     (p "Para 4")))

 ;; lists with indented code
 ;; NOTE: this test is disabled, since code-indents within lists
 ;; aren't supported yet.
 #;(let ((md (parse-markdown-string
#"""
Text

  * Itemised list,
    with 4-space indent:

        nameptr #1 >
          { ... }
          't
        if$

    Next paragraph.

More text.""")))
   (assert-equal md
                 '(div xxx)))

;;;; Inline structure

 ;; inline structure: emphases
 (for-each (lambda (p)
             (assert-equal (parse-markdown-string (car p)) (cadr p)))
           '(("Item _em *_, _em **strong**_, _em __strong___"
              (div (p "Item " (em "em " "*") ", "
                      (em "em " (strong "strong")) ", "
                      (em "em " (strong "strong")))))
             ("Item *em _*, *em **strong***, *em __strong__*"
              (div (p "Item " (em "em " "_") ", "
                      (em "em " (strong "strong")) ", "
                      (em "em " (strong "strong")))))
             ;; changing `... **strong *em* **` to `... **strong
             ;; *em***` produces a syntax error -- I wonder if I need
             ;; to care about that
             ("Item **strong __**, **strong _em_**, **strong *em* **"
              (div (p "Item " (strong "strong " "__") ", "
                      (strong "strong " (em "em")) ", "
                      (strong "strong " (em "em") " "))))
             ("Item __strong **__, __strong _em_ __, __strong *em*__"
              (div (p "Item " (strong "strong " "**") ", "
                      (strong "strong " (em "em") " ") ", "
                      (strong "strong " (em "em")))))
             ("Item *em"
              (div (p "Item " (em "em"))))
             ("Item _em"
              (div (p "Item " (em "em"))))
             ("Item **strong"
              (div (p "Item " (strong "strong"))))
             ("Item __strong"
              (div (p "Item " (strong "strong"))))
             ("Item *em **strong"
              (div (p "Item " (em "em " (strong "strong")))))
             ("Item _em __strong"
              (div (p "Item " (em "em " (strong "strong")))))
             ("Item **strong _em"
              (div (p "Item " (strong "strong " (em "em" )))))
             ("Item __strong _em"
              (div (p "Item " (strong "strong " (em "em" )))))

             ;; emphasis inside links
             ("_[text _em_](link)_"
              (div (p (em (a ((href "link")) "text " (em "em"))))))
             ;; various unclosed cases
             ("*[text __strong](link)"
              (div (p (em (a ((href "link")) "text " (strong "strong"))))))
             ("__[text __strong](link)"
              (div (p (strong (a ((href "link")) "text " (strong "strong"))))))))

 ;; quoted paragraphs:
 ;; paragraphs within
 (assert-equal (parse-markdown-string
                #"""
Leading empty line.

> quotation1 _and_
>quotation2
>
> quotation3

Next paragraph.""")
               '(div (p "Leading empty line.")
                     (blockquote
                      (p "quotation1 " (em "and") " quotation2")
                      (p "quotation3"))
                     (p "Next paragraph.")))

 ;; multiple levels
 (assert-equal (parse-markdown-string
                #"""
> level1
>  > level2
> level1 again

Text
>>>level3
>   >  level2: jump to zero

Text
> level1: block is not ended by unprefixed text
level0
""")
               '(div
                 (blockquote
                  (p "level1")
                  (blockquote
                   (p "level2"))
                  (p "level1 again"))
                 (p "Text")
                 (blockquote
                  (blockquote
                   (blockquote
                    (p "level3"))
                   (p "level2: jump to zero")))
                 (p "Text")
                 (blockquote
                  (p "level1: block is not ended by unprefixed text level0"))))

 ;; in multiple levels at EOF
 ;; (it's important for the test that the string ends without a
 ;; trailing newline, since that tests the code, in
 ;; parse-markdown.lex, that handles <<EOF>>: if we don't do this,
 ;; then that code-path isn't tested, because
 ;; parse_markdown_setup_string carefully adds an extra newline to
 ;; this buffer).
 (assert-equal (parse-markdown-string
                #"""Line

>> level2, ends file""")
               '(div
                 (p "Line")
                 (blockquote
                  (blockquote
                   (p "level2, ends file")))))

 ;;;; horizontal rules
 (assert-equal (parse-markdown-string
                #"""This is a heading
----

But this line is followed by a rule.

----

And this is a two-line paragraph.
Which is followed by a rule.
* * * * * * *
And another paragraph
- - -
But this isn't a rule:
* x *

Or this:

- * - *

Paragraph""")
               '(div
                 (h2 (a ((name "this-is-a-heading")) "This is a heading"))
                 (p "But this line is followed by a rule.")
                 (hr)
                 (p "And this is a two-line paragraph. Which is followed by a rule.")
                 (hr)
                 (p "And another paragraph")
                 (hr)
                 (p "But this isn't a rule:")
                 ;; The following may or may not be the best result here.
                 ;; The mdinline parser, based on what the lexer interpolates at end-of-string,
                 ;; interprets '- *' as '- *[nothing]*' and parses that as an empty <em> element.
                 ;; I'm not convinced thta's sensible.
                 (ul (li "x " (em)))
                 (p "Or this:")
                 (ul (li (em " - "))) ;<-- a bit of a mess, but not an HR
                 (p "Paragraph")))

 
;;;; Links, various

;; various varieties of link
 (let ((md (parse-markdown-string #"""
    a [text](url), b [t _em_](http://foo.bar),
    c _this [is](url) a link_, d this is a [[ref]](url),
    e a [text](url "with title"),
    f an ![image _emph_](url),
    g an ![image] (  url   'with single-quoted (title))'  ), and
    h an ![image](url '') empty title.
    Lone exclamation!

    And this is an inline link: <http://example.org>.
    But > and < aren't.
    """)))
       (assert-equal md
                 '(div
                   (p "a " (a ((href "url")) "text")
                      ", b " (a ((href "http://foo.bar")) "t " (em "em"))
                      ", c " (em "this "
                                 (a ((href "url")) "is")
                                 " a link")
                      ", d this is a " (a ((href "url")) "[" "ref" "]")
                      ", e a " (a ((href "url") (title "with title")) "text")
                      ", f an " (img ((src "url") (alt "image emph")))
                      ", g an " (img ((src "url") (alt "image") (title "with single-quoted (title))")))
                      ", and h an " (img ((src "url") (alt "image"))) ;no title
                      " empty title. Lone exclamation" "!")
                   (p "And this is an inline link: "
                      (a ((href "http://example.org")) (code "http://example.org"))
                      ". But " ">" " and " "<" " aren't."))))

 (let ((md (parse-markdown-string
            #"""
            Text

            ![image](url)

            ![image1](url1 "title")
            ![image2](url2) and other text

            Next para""")))
   (assert-equal md
                 '(div
                   (p "Text")
                   (figure
                    (img ((src "url") (alt "image")))
                    (figcaption "image"))
                   (figure
                    (img ((src "url1") (alt "image1") (title "title")))
                    " "
                    (img ((src "url2") (alt "image2")))
                    " and other text"
                    (figcaption "title"))
                   (p "Next para"))))

 (let ((md (parse-markdown-string
            ;; the link key is processed case-insensitively;
            ;; should the 'broken link' link produce a warning?
            #"""A [reference link][ref1], [link _with_ space]  [ref2],
            an implicit link [Google Homepage][] and an [odd link][LiNk-with&stuff],
            and an implicit one with a title for [Norman][].
            Plus a [broken link][refnot].
            [REF1]: http://example.org/1
            [ref2]: <http://example.org/2> 'Title of link'
            [Norman]:    http://nxg.me.uk  (Norman's page)
            [google HOMEPAGE]:     http://google.com   
            [LINK-with&stuff]: http://links.org""")))
   (assert-equal md
                 '(div
                   (p
                    "A " (a ((href "http://example.org/1")) "reference link")
                    ", " (a ((href "http://example.org/2") (title "Title of link")) "link " (em "with") " space")
                    ", an implicit link " (a ((href "http://google.com")) "Google Homepage")
                    " and an " (a ((href "http://links.org")) "odd link")
                    ", and an implicit one with a title for " (a ((href "http://nxg.me.uk") (title "Norman's page")) "Norman")
                    ". Plus a "
                    (a ((href "dummylink")) "broken link") "."))))
 (let ((md (parse-markdown-string
            ;; check with non-ASCII characters in various places
            ;; and in various cases
            "A [reférence link][RÜfé1]\n[rüFÉ1]: <http://example.org> 'Überschrift'\n")))
   (assert-equal md
                 '(div
                   (p
                    "A "
                    (a ((href "http://example.org") (title "Überschrift")) "reférence link")))))

 ;;;; citations: incomplete implementation and tests
 (receive (parse-tree metadata)
     (parse-markdown-string/metadata "one [@key.1], two [@{key--2} text; and @key.3--more]")
   (assert-equal parse-tree
                 '(div
                   (p "one "
                      (span ((class "citation")) "(" (cite "key.1") ")")
                      ", two "
                      (span ((class "citation")) "(" (cite "key--2") " text" "; " "and " (cite "key.3") "--more" ")"))))
   (let ((refs (metadata/type metadata 'citation)))
     (assert-equal (sort! refs
                          (λ (a b) (symbol<? (car a) (car b))))
                   '((key--2 (cite "key--2"))
                     (key.1  (cite "key.1"))
                     (key.3  (cite "key.3"))))
     ;; confirm that we can change the (cite ...) elements in the parse-tree
     (for-each (λ (kv) ; kv is ("string" (cite "string"))
                 (let ((k (car kv))
                       (v (cadr kv)))
                   (set-cdr! v (list (sprintf "[[~a]]" k)))))
               refs)
     (assert-equal parse-tree
                   '(div
                     (p "one "
                        (span ((class "citation")) "(" (cite "[[key.1]]") ")")
                        ", two "
                        (span ((class "citation")) "(" (cite "[[key--2]]") " text" "; " "and "
                              (cite "[[key.3]]") "--more" ")"))))))

 (receive (parse-tree metadata)
     ;; the following, in a document, would probably be regarded as
     ;; simply garbled, but shouldn't be regarded as refs
     (parse-markdown-string/metadata "not [@] a ref; not [@@] neither")
   (assert-equal parse-tree
                 '(div (p "not [@] a ref; not [@@] neither"))))

 ;; Parsing metadata: Note that "Text\n---\nkey: value\n" will be
 ;; parsed as metadata.  That's not intended, but is warned against in
 ;; the documentation.
 (receive (parse-tree metadata)
     (parse-markdown-string/metadata
      #"""---
      key1: value1
      key2: value number two
      clé3 x: numéro trois

      Hello

      ---
      That was a rule

      Another section
      ---
      Paragraph

      ---
      key4: more

      Another paragraph: and example metadata

      ----
      example: value

      And finally""")
   (assert-equal parse-tree
                 '(div (p "Hello")
                       (hr)
                       (p "That was a rule")
                       (h2 (a ((name "another-section")) "Another section"))
                       (p "Paragraph")
                       (p "Another paragraph: and example metadata")
                       (p "And finally")))
   (let ((annotations (metadata/type metadata 'annotation)))
     (assert-equal (sort! annotations
                          (λ (a b) (string<? (car a) (car b))))
                   '(("clé3 x" "numéro trois")
                     ("example" "value")
                     ("key1" "value1")
                     ("key2" "value number two")
                     ("key4" "more")))))

 ;; non-link [...] are OK
 (assert-equal (parse-markdown-string "not [a link] and nor is [this] one")
               '(div (p "not " "[" "a link" "]" " and nor is " "[" "this" "]" " one")))
 (assert-equal (parse-markdown-string "There is [only] one link [here](urn:example.org).")
               '(div (p "There is " "[" "only" "]" " one link " (a ((href "urn:example.org")) "here") ".")))

 ;;;; Various pathologies

 ;; miscellaneous odd link and not-actually-link cases
 (assert-equal (parse-markdown-string "unmatched right square ] bracket")
               '(div (p "unmatched right square " "]" " bracket")))
 (assert-equal (parse-markdown-string "unmatched left square [ bracket")
               '(div (p "unmatched left square " "[" " bracket" "")))
 (assert-equal (parse-markdown-string "unmatched trailing square [")
               '(div (p "unmatched trailing square " "[" "")))
 (assert-equal (parse-markdown-string "link [text]()") ; with no link
               '(div (p "link " (a ((href "")) "text"))))
 (assert-equal (parse-markdown-string "link [text](url '')") ; link and empty title
               '(div (p "link " (a ((href "url")) "text"))))
 (assert-equal (parse-markdown-string "link [text] ( 'title')") ; no link, but with title and extra WS
               '(div (p "link " (a ((href "") (title "title")) "text"))))
 (assert-equal (parse-markdown-string "link [text]('')") ; no link and empty title
               '(div (p "link " (a ((href "")) "text"))))
 ;; FIXME: the following test doesn't pass, because the lexing of the URL here isn't
 ;; as sophisticated as it could be -- see the FIXME in parse-mdinline.lex.
 ;; (assert-equal (parse-markdown-string   ;lots of parentheses!
 ;;                "(language [Scheme(](https://en.wikipedia.org/wiki/Scheme_(programming_language))))?")
 ;;               '(div (p "(language "
 ;;                        (a ((href "https://en.wikipedia.org/wiki/Scheme_(programming_language)"))
 ;;                           "Scheme(")
 ;;                        "))?")))
 ;; (assert-equal (parse-markdown-string   ;same, with parentheses in the title
 ;;                "[Scheme](https://en.wikipedia.org/wiki/Scheme_(programming_language) \"title)(\")))?")
 ;;               '(div (p (a ((href "https://en.wikipedia.org/wiki/Scheme_(programming_language)")
 ;;                            (title "title)("))
 ;;                           "Scheme")
 ;;                        "))?")))
 ;; same four with images
 (assert-equal (parse-markdown-string "image ![alt]()") ; with no link
               '(div (p "image " (img ((src "") (alt "alt"))))))
 (assert-equal (parse-markdown-string "image ![alt](  \t )") ; whitespace link?
               '(div (p "image " (img ((src "") (alt "alt"))))))
 (assert-equal (parse-markdown-string "image ![alt] ( url '')") ; link, empty title, and extra WS
               '(div (p "image " (img ((src "url") (alt "alt"))))))
 (assert-equal (parse-markdown-string "image ![alt]('title')") ; no link, but with title
               '(div (p "image " (img ((src "") (alt "alt") (title "title"))))))
 (assert-equal (parse-markdown-string "image ![alt]('')") ; no link and empty title
               '(div (p "image " (img ((src "") (alt "alt"))))))

 ;; odder ones
 ;; (note that in the next two cases, the \n can't be followed by
 ;; spaces, or else this is lexed by parse-markdown as an indented line)
 (assert-equal (parse-markdown-string "link [text]( \n)") ;non-horizontal whitespace
               '(div (p "link " (a ((href "")) "text"))))
 (assert-equal (parse-markdown-string "image ![alt]( \n)") ;no link or title, and non-horizontal WS
               '(div (p "image " (img ((src "") (alt "alt"))))))

 (let ((nw (print-warning 'get-count)))
   ;; this should produce two parse warnings
   (assert-equal (parse-markdown-string "not [actually]( a link")
                 '(div (p "not [actually]( a link")))
   (assert-equal (print-warning 'get-count) (+ nw 2)))
 ;; I don't think the following is the best behaviour,  but see comments
 ;; around the IN_ENDLiNK case in parse-mdinline.lex
 ;; FIXME: I'm not sure how to hendle this case.  See the FIXMEs above
 ;; and in parse-mdinline.lex
 ;;(assert-exception (parse-markdown-string "not [actually](a"))

 (assert-equal (parse-markdown-string "a [malformed](\"link\")")
               '(div (p "a " (a ((href "") (title "link")) "malformed"))))
 ;; I think the following should _not_ work --
 ;; this should produce a syntax error as an unexpected LINK
 #;(assert-equal (parse-markdown-string "a [text ] with](link) a bracket inside")
               '(div (p "a " (a ((href "link")) "text " "]" " with") " a bracket inside")))
 (assert-equal (parse-markdown-string "a [[ref]]() link")
               '(div (p "a " (a ((href "")) "[" "ref" "]") " link")))
 (assert-equal (parse-markdown-string "[text](link) at start")
               '(div (p (a ((href "link")) "text") " at start")))
 (assert-equal (parse-markdown-string "[non-link] at start")
               '(div (p "[" "non-link" "]" " at start")))

 ;; The following is all the ASCII printing characters, except [*_<>\].
 ;; Some of the 'active' characters not in pattern ORDINARY are present here,
 ;; but not in the patterns which produce lexemes other than TEXT.
 (assert-equal (parse-markdown-string
                "!\"#$%&'()+,-./0123456789:;=?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[]^`abcdefghijklmnopqrstuvwxyz{|}~")
               '(div (p "!\"#$%&'()+,-./0123456789:;=?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[]^`abcdefghijklmnopqrstuvwxyz{|}~")))

 ;; escapes
 (assert-equal (parse-markdown-string "\\\\\\`\\*\\_\\{\\}\\[\\]\\(\\)\\#\\+\\-\\.\\!")
               '(div (p "\\" "`" "*" "_" "{" "}" "[" "]" "(" ")" "#" "+" "-" "." "!")))
 )

(exit/failures)