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