1{-# LANGUAGE CPP #-} 2{-# LANGUAGE OverloadedStrings #-} 3{-# LANGUAGE ScopedTypeVariables #-} 4 5import Commonmark 6import Commonmark.Extensions 7import Control.Monad (when) 8import Data.Functor.Identity 9import Data.List (groupBy) 10import Data.Text (Text) 11import qualified Data.Text as T 12import qualified Data.Text.IO as T 13import System.IO (hSetEncoding, utf8, openFile, 14 IOMode(..)) 15import qualified Data.Text.Lazy as TL 16import Test.Tasty 17import Test.Tasty.HUnit 18import Text.Parsec 19import Text.Parsec.Pos 20#if !MIN_VERSION_base(4,11,0) 21import Data.Semigroup 22#endif 23 24readTextFile :: FilePath -> IO Text 25readTextFile fp = do 26 h <- openFile fp ReadMode 27 hSetEncoding h utf8 28 T.hGetContents h 29 30main :: IO () 31main = do 32 tests <- mapM (uncurry getSpecTestTree) 33 [ ("test/smart.md", smartPunctuationSpec) 34 , ("test/hard_line_breaks.md", hardLineBreaksSpec) 35 , ("test/strikethrough.md", strikethroughSpec) 36 , ("test/superscript.md", superscriptSpec) 37 , ("test/subscript.md", subscriptSpec) 38 , ("test/pipe_tables.md", pipeTableSpec) 39 , ("test/footnotes.md", footnoteSpec) 40 , ("test/math.md", mathSpec) 41 , ("test/emoji.md", emojiSpec) 42 , ("test/autolinks.md", autolinkSpec) 43 , ("test/definition_lists.md", definitionListSpec) 44 , ("test/fancy_lists.md", fancyListSpec) 45 , ("test/task_lists.md", taskListSpec) 46 , ("test/attributes.md", attributesSpec) 47 , ("test/raw_attribute.md", rawAttributeSpec) 48 , ("test/bracketed_spans.md", bracketedSpanSpec) 49 , ("test/fenced_divs.md", fencedDivSpec) 50 , ("test/auto_identifiers.md", autoIdentifiersSpec <> attributesSpec) 51 , ("test/implicit_heading_references.md", 52 autoIdentifiersSpec <> attributesSpec <> implicitHeadingReferencesSpec) 53 ] 54 defaultMain $ testGroup "Tests" tests 55 56getSpecTestTree :: FilePath 57 -> SyntaxSpec Identity (Html ()) (Html ()) 58 -> IO TestTree 59getSpecTestTree fp syntaxspec = do 60 spectests <- getSpecTests fp 61 let spectestgroups = groupBy (\t1 t2 -> section t1 == section t2) 62 spectests 63 let spectestsecs = [(section (head xs), xs) | xs <- spectestgroups] 64 let parser = runIdentity . parseCommonmarkWith 65 (syntaxspec <> defaultSyntaxSpec) 66 return $ testGroup fp $ 67 map (\(secname, tests) -> 68 testGroup (T.unpack secname) $ 69 map (toSpecTest parser) tests) 70 spectestsecs 71 72getSpecTests :: FilePath -> IO [SpecTest] 73getSpecTests fp = do 74 speclines <- zip [1..] . T.lines . T.replace "→" "\t" 75 <$> readTextFile fp 76 return $ either (error . show) id $ runParser 77 (many (try (skipMany normalLine *> parseSpecTest)) 78 <* skipMany normalLine <* eof) ("",1) fp 79 speclines 80 81data SpecTest = SpecTest 82 { section :: Text 83 , example :: Int 84 , markdown :: Text 85 , end_line :: Int 86 , start_line :: Int 87 , html :: Text } 88 deriving (Show) 89 90toSpecTest :: ([Tok] -> Either ParseError (Html ())) 91 -> SpecTest -> TestTree 92toSpecTest parser st = 93 testCase name (actual @?= expected) 94 where name = T.unpack (section st) ++ " example " ++ show (example st) ++ 95 " (" ++ show (start_line st) ++ "-" ++ 96 show (end_line st) ++ ")" 97 expected = normalizeHtml $ html st 98 actual = normalizeHtml . TL.toStrict . renderHtml . 99 fromRight mempty $ 100 (parser (tokenize "" (markdown st)) 101 :: Either ParseError (Html ())) 102 103normalizeHtml :: Text -> Text 104normalizeHtml = T.replace "\n</li>" "</li>" . 105 T.replace "<li>\n" "<li>" 106 107fromRight :: b -> Either a b -> b 108fromRight fallback (Left _) = fallback 109fromRight _ (Right x) = x 110 111--- parser for spec test cases 112 113satisfyLine :: (Text -> Bool) 114 -> Parsec [(Int, Text)] (Text, Int) Text 115satisfyLine f = token showTok posFromTok testTok 116 where 117 showTok (_,t) = T.unpack t 118 posFromTok (pos,_) = newPos "" pos 1 119 testTok (_,t) = if f t then Just t else Nothing 120 121parseSpecTest :: Parsec [(Int, Text)] (Text, Int) SpecTest 122parseSpecTest = do 123 startpos <- getPosition 124 () <$ satisfyLine (== "```````````````````````````````` example") 125 markdownTxt <- T.unlines <$> manyTill (satisfyLine (const True)) 126 (satisfyLine (==".")) 127 htmlTxt <- T.unlines <$> manyTill (satisfyLine (const True)) 128 (satisfyLine (== "````````````````````````````````")) 129 endline <- (\x -> x - 1) . sourceLine <$> getPosition 130 (sectionName, exampleNumber) <- getState 131 putState (sectionName, exampleNumber + 1) 132 return SpecTest{ 133 section = sectionName 134 , example = exampleNumber 135 , markdown = markdownTxt 136 , end_line = endline 137 , start_line = sourceLine startpos 138 , html = htmlTxt 139 } 140 141normalLine :: Parsec [(Int, Text)] (Text, Int) () 142normalLine = do 143 t <- satisfyLine (/= "```````````````````````````````` example") 144 when ("#" `T.isPrefixOf` t) $ updateState $ \(_secname, exampnum) -> 145 (T.strip $ T.dropWhile (=='#') t, exampnum) 146 147--- 148