module Main where import Data.String.Utils import Text.Parsec import System.Exit import qualified Options import Parsing.Parse import Parsing.ParseBlock import Parsing.ParseHtml import Parsing.ParseInline import Parsing.State import Rendering.Render import Rendering.RenderOptions printExpectedSuccess :: (ToHtml a) => String -> String -> String -> a -> IO Bool printExpectedSuccess name input expected parsed = if output == expected then do putStrLn $ "PASS: " ++ name return True else do putStrLn $ "FAIL: " ++ name putStrLn "in:" putStrLn input putStrLn "out:" putStrLn output putStrLn "expect:" putStrLn expected return False where output = toHtml defaultRenderOptions parsed expectSuccess :: (ToHtml a) => String -> (Parser a) -> String -> String -> IO Bool expectSuccess name p input expected = either (\err -> do putStrLn $ "FAIL: " ++ name putStrLn $ show err return False) (printExpectedSuccess name input expected) $ runParser p initialState name input testItalics = expectSuccess "italics" inline "*abc*" "abc" testBold = expectSuccess "bold" inline "**abc**" "abc" testBoldItalics = expectSuccess "bold italics" inline "***abc***" "abc" testCode = expectSuccess "code" inline "`abc`" "abc" testInlineHtml = expectSuccess "inline html" html "SQL" "SQL" testMultipleAttrs = expectSuccess "html with multiple attrs" html "SQL" "SQL" testFootnoteRef = expectSuccess "footnote reference" inline "^[x]" "[0]" testCaret = expectSuccess "literal '^' does not need escaping" inline "^" "^" testImage = expectSuccess "inline image" inline "![an image](/img/0)" "\"an" testExclamationMark = expectSuccess "literal '!' does not need escaping" inline "!" "!" testLink = expectSuccess "link" inline "[Google](https://google.com)" "Google" testLinkWithContents = expectSuccess "link with styling inside" inline "[*Whence* `he` **came**](https://google.com)" "Whence he came" testLinkImplicit = expectSuccess "link with implicit href" inline "[https://google.com]" "https://google.com" testH1 = expectSuccess "h1" header "# hello" "

hello

" testH6 = expectSuccess "h6" header "###### hello" "
hello
" testHardRule = expectSuccess "hard rule" hardRule "---\n" "
" testHardRuleLong = expectSuccess "hard rule with extra dashes" hardRule "----\n" "
" testParagraph = expectSuccess "paragraph" paragraph "This is a paragraph\n\ \of text.\n" "

This is a paragraph\n\ \of text.

" testEscapeCharacters = expectSuccess "paragraph with escaped special characters" paragraph "These are special: \\~, \\*, \\[, \\], \\^\n" "

These are special: ~, *, [, ], ^

" testHashInParagraph = expectSuccess "paragraph containing literal '#'" paragraph "This is a paragraph\n\ \containing '#'\n" "

This is a paragraph\n\ \containing '#'

" testOrderedList = expectSuccess "ol" listBlock " - point 1\n\ \ - point 2\n" "
  1. point 1
  2. \n\ \
  3. point 2
  4. \n\ \
" testUnorderedList = expectSuccess "ul" listBlock " * point 1\n\ \ * point 2\n" "" testNestedList = expectSuccess "nested list" listBlock " - point 1\n\ \ - point 2\n\ \ * point 3\n\ \ * point 4\n\ \ - point 5\n\ \ * point 6\n\ \ - point 7\n" "
  1. point 1
  2. \n\ \
  3. point 2
  4. \n\ \\n\ \
  5. point 7
  6. \n\ \
" testBlockQuote = expectSuccess "blockquote" blockQuote "> The politician said that\n\ \> he would fix the economy.\n" "
The politician said that\n\ \he would fix the economy.
" testBlockQuotePreFormatted = expectSuccess "blockquote pre-formatted" blockQuote "> \"This is it... this is where I belong...\"\n\ \> I know everyone here... even if I've never met them, never talked to\n\ \> them, may never hear from them again... I know you all...\n" "
\"This is it... this is where I belong...\"\n\ \ I know everyone here... even if I've never met them, never talked to\n\ \them, may never hear from them again... I know you all...
" testBlockCode = expectSuccess "block code" blockCode " var x = 0;\n\ \ alert(x);\n" "
var x = 0;\n\
    \alert(x);\n\
    \
" testBlockCodeWhitespace = expectSuccess "block code handles starting whitespace correctly" blockCode " def f(x):\n\ \ return x\n" "
def f(x):\n\
    \    return x\n\
    \
" testBlockCodeSpecialChars = expectSuccess "any line beginning with four spaces should be a block of code, regardless of the first non-whitespace character" block " > print(1)\n\ \ * 1" "
> print(1)\n\
    \* 1\n\
    \
" testBlockHtml = expectSuccess "block html" blockHtml "
\n\ \ \n\ \
" "
\n\ \ \n\ \
" testTable = expectSuccess "table" table "+---+---+\n\ \| a | b |\n\ \| c | d |\n\ \+---+---+\n" "\n\ \\n\ \\n\ \\n\ \\n\ \\n\ \
a b
c d
" testTableHeader = expectSuccess "table with header" table "+---+---+\n\ \| a | b |\n\ \+---+---+\n\ \| c | d |\n\ \| e | f |\n\ \+---+---+\n" "\n\ \\n\ \\n\ \\n\ \\n\ \\n\ \\n\ \\n\ \\n\ \
a b
c d
e f
" testTableMinimal = expectSuccess "minimal table" table "| a | b |\n\ \| c | d |\n" "\n\ \\n\ \\n\ \\n\ \\n\ \\n\ \
a b
c d
" testTableHeaderMinimal = expectSuccess "minimal table with header" table "| a | b |\n\ \+\n\ \| c | d |\n\ \| e | f |\n" "\n\ \\n\ \\n\ \\n\ \\n\ \\n\ \\n\ \\n\ \\n\ \
a b
c d
e f
" testFootnoteDef = expectSuccess "footnote definition" ast "^[x]\n\ \~[x] This is a single list item\n\ \of footnote.\n" "

[0]

\n\ \
  1. This is a single list item\n\ \of footnote.

  2. \n\ \
\n" testFootnoteDefTwoLines = expectSuccess "footnote definition, separated by 2 lines" ast "^[x]\n\ \\n\ \~[x] This is a single list item\n\ \of footnote.\n" "

[0]

\n\ \
  1. This is a single list item\n\ \of footnote.

  2. \n\ \
\n" testFootnoteDefs = expectSuccess "multiple footnote definitions" ast "^[0]^[1]^[2]\n\ \~[0] a\n\ \~[1] b\n\ \\n\ \~[2] c\n" "

[0][1][2]

\n\ \
  1. a

  2. \n\ \
  3. b

  4. \n\ \
  5. c

  6. \n\ \
\n" testFootnoteOrdering = expectSuccess "footnotes should be sorted by first reference" ast "^[0]^[1]\n\ \~[1] b\n\ \~[0] a\n" "

[0][1]

\n\ \
  1. a

  2. \n\ \
  3. b

  4. \n\ \
\n" testContinuation = expectSuccess "continuation character" paragraph "a\\\nb" "

ab

" expectFailure :: (ToHtml a) => String -> (Parser a) -> String -> String -> IO Bool expectFailure name p input expectedErr = either (\err -> if endswith expectedErr $ show err then do putStrLn $ "PASS: " ++ name return True else do putStrLn $ "FAIL: " ++ name putStrLn "in:" putStrLn input putStrLn "out:" putStrLn $ show err putStrLn "expect:" putStrLn expectedErr return False) (\parsed -> do putStrLn $ "FAIL: " ++ name putStrLn $ "unexpected success:" putStrLn $ toHtml defaultRenderOptions parsed return False) $ runParser p initialState name input testNestedBold = expectFailure "bold tags cannot be nested" inline "****abc****" "cannot have empty or nested bold nodes" testMismatchedBoldItalics = expectFailure "bold opening tag closed with italics tag" inline "**a*" "expecting content in italics node or extra \"*\" to close bold node" testSwappedItalicsBold = expectFailure "italics and bold closing tags swapped" paragraph "*a**b*c**" "unexpected \"c\"\n\ \expecting closing \"**\" (bold)" testNestedLink = expectFailure "links cannot be nested" inline "[[a](https://a.com)](https://b.com)" "unexpected \"[\"\n\ \expecting \"**\" (bold), \"*\" (italics), \"`\" (code), \"^[\" (footnote reference), \"![\" (image) or \"<\" (html tag)\n\ \links cannot be nested" testBadImplicitLink = expectFailure "link href required unless text is valid URI" inline "[notauri]" "unexpected end of input\n\ \expecting \"(\" (link href)\n\ \link href is required unless link text is a valid absolute URI" testUnclosedOpeningTag = expectFailure "unclosed opening tag should fail to parse" html "\" (html tag)" testUnclosedTag = expectFailure "unclosed tag should fail to parse" html "

hello" "unexpected end of input\n\ \expecting \"<\" (html tag) or \"hello" "mismatched tags: 'a' and 'b'" testScriptTag = expectFailure "script tags unsafe" html "" "script tags cannot safely be parsed\n\ \pass --allow-unsafe-tags to try anyway" testStyleTag = expectFailure "style tags unsafe" html "" "style tags cannot safely be parsed\n\ \pass --allow-unsafe-tags to try anyway" testBadTableSeparator = expectFailure "incomplete table separator" block "+---+---\n\ \| a | b |" "unexpected \"\\n\"\n\ \expecting \"-\" or \"+\" (table)" testBadListNesting = expectFailure "incorrectly nested lists" ast " * a\n\ \ * b\n" "unexpected \" \"\n\ \expecting \" - \" (ordered list item) or \" * \" (unordered list item)" goldenTest :: FilePath -> FilePath -> String -> IO Bool goldenTest inFilePath goldenFilePath renderArgs = do let (p, r) = Options.options $ words renderArgs input <- readFile inFilePath golden <- readFile goldenFilePath either (\err -> do putStrLn $ "FAIL: " ++ goldenFilePath putStrLn $ show err return False) (\parsed -> do let rendered = toHtml r parsed if rendered == golden then do putStrLn $ "PASS: " ++ goldenFilePath return True else do let failPath = goldenFilePath ++ ".fail" writeFile failPath rendered putStrLn $ "FAIL: " ++ goldenFilePath return False) $ runParser ast (initialState {options=p}) inFilePath input main :: IO () main = do results <- sequence [ testItalics, testBold, testBoldItalics, testCode, testInlineHtml, testMultipleAttrs, testFootnoteRef, testLink, testLinkWithContents, testLinkImplicit, testCaret, testImage, testExclamationMark, testH1, testH6, testHardRule, testHardRuleLong, testParagraph, testEscapeCharacters, testHashInParagraph, testOrderedList, testUnorderedList, testNestedList, testBlockQuote, testBlockQuotePreFormatted, testBlockCode, testBlockCodeWhitespace, testBlockCodeSpecialChars, testBlockHtml, testTable, testTableHeader, testTableMinimal, testTableHeaderMinimal, testFootnoteDef, testFootnoteDefTwoLines, testFootnoteDefs, testFootnoteOrdering, testContinuation, testNestedBold, testMismatchedBoldItalics, testSwappedItalicsBold, testNestedLink, testBadImplicitLink, testUnclosedOpeningTag, testUnclosedTag, testMismatchedTags, testScriptTag, testStyleTag, testBadTableSeparator, testBadListNesting, goldenTest "Readme.md" "test/goldens/Readme.html" "--em-dashes --inline-css --inline-js", goldenTest "test/goldens/golden1.md" "test/goldens/golden1.html" "--em-dashes", goldenTest "test/goldens/golden1.md" "test/goldens/golden1-backlinks.html" "--em-dashes --footnote-backlinks", goldenTest "test/goldens/golden2.md" "test/goldens/golden2.html" "--em-dashes", goldenTest "test/goldens/golden2.md" "test/goldens/golden2-backlinks.html" "--em-dashes --footnote-backlinks", goldenTest "test/goldens/bleach.md" "test/goldens/bleach.html" "--allowed-tags span --allowed-attributes class", goldenTest "test/goldens/bleach.md" "test/goldens/bleach-all.html" "--allowed-tags --allowed-attributes"] if and results then exitSuccess else exitFailure