test/Tests/Readers/HTML.hs · typeable/pandoc

git.iko.soy/typeable/pandoc

on 3645607 help sign in

typeable/pandoc/test/Tests/Readers/HTML.hs

112 lines 5.3 kB history raw

1{-# LANGUAGE OverloadedStrings #-}

2{- |

3 Module : Tests.Readers.HTML

5 License : GNU GPL, version 2 or above

7 Maintainer : John MacFarlane <jgm@berkeley.edu>

8 Stability : alpha

9 Portability : portable

11Tests for the HTML reader.

12-}

13module Tests.Readers.HTML (tests) where

15import Data.Text (Text)

16import qualified Data.Text as T

17import Test.Tasty

18import Test.Tasty.QuickCheck

19import Test.Tasty.Options (IsOption(defaultValue))

20import Tests.Helpers

21import Text.Pandoc

22import Text.Pandoc.Shared (isHeaderBlock)

23import Text.Pandoc.Arbitrary ()

24import Text.Pandoc.Builder

25import Text.Pandoc.Walk (walk)

27html :: Text -> Pandoc

28html = purely $ readHtml def

30htmlNativeDivs :: Text -> Pandoc

31htmlNativeDivs = purely $ readHtml def { readerExtensions = enableExtension Ext_native_divs $ readerExtensions def }

33makeRoundTrip :: Block -> Block

34makeRoundTrip CodeBlock{} = Para [Str "code block was here"]

35makeRoundTrip LineBlock{} = Para [Str "line block was here"]

36makeRoundTrip RawBlock{} = Para [Str "raw block was here"]

37makeRoundTrip (Div attr bs) = Div attr $ filter (not . isHeaderBlock) bs

38-- avoids round-trip failures related to makeSections

39-- e.g. with [Div ("loc",[],[("a","11"),("b_2","a b c")]) [Header 3 ("",[],[]) []]]

40makeRoundTrip Table{} = Para [Str "table block was here"]

41makeRoundTrip x = x

43removeRawInlines :: Inline -> Inline

44removeRawInlines RawInline{} = Str "raw inline was here"

45removeRawInlines x = x

47roundTrip :: Blocks -> Bool

48roundTrip b = d'' == d'''

49 where d = walk removeRawInlines $

50 walk makeRoundTrip $ Pandoc nullMeta $ toList b

51 d' = rewrite d

52 d'' = rewrite d'

53 d''' = rewrite d''

54 rewrite = html . (`T.snoc` '\n') .

55 purely (writeHtml5String def

56 { writerWrapText = WrapPreserve })

58tests :: [TestTree]

59tests = [ testGroup "base tag"

60 [ test html "simple" $

61 "<head><base href=\"http://www.w3schools.com/images/foo\" ></head><body><img src=\"stickman.gif\" alt=\"Stickman\"></head>" =?>

62 plain (image "http://www.w3schools.com/images/stickman.gif" "" (text "Stickman"))

63 , test html "slash at end of base" $

64 "<head><base href=\"http://www.w3schools.com/images/\" ></head><body><img src=\"stickman.gif\" alt=\"Stickman\"></head>" =?>

65 plain (image "http://www.w3schools.com/images/stickman.gif" "" (text "Stickman"))

66 , test html "slash at beginning of href" $

67 "<head><base href=\"http://www.w3schools.com/images/\" ></head><body><img src=\"/stickman.gif\" alt=\"Stickman\"></head>" =?>

68 plain (image "http://www.w3schools.com/stickman.gif" "" (text "Stickman"))

69 , test html "absolute URL" $

70 "<head><base href=\"http://www.w3schools.com/images/\" ></head><body><img src=\"http://example.com/stickman.gif\" alt=\"Stickman\"></head>" =?>

71 plain (image "http://example.com/stickman.gif" "" (text "Stickman"))

72 ]

73 , testGroup "anchors"

74 [ test html "anchor without href" $ "<a name=\"anchor\"/>" =?>

75 plain (spanWith ("anchor",[],[]) mempty)

76 ]

77 , testGroup "lang"

78 [ test html "lang on <html>" $ "<html lang=\"es\">hola" =?>

79 setMeta "lang" (text "es") (doc (plain (text "hola")))

80 , test html "xml:lang on <html>" $ "<html xmlns=\"http://www.w3.org/1999/xhtml\" xml:lang=\"es\"><head></head><body>hola</body></html>" =?>

81 setMeta "lang" (text "es") (doc (plain (text "hola")))

82 ]

83 , testGroup "main"

84 [ test htmlNativeDivs "<main> becomes <div role=main>" $ "<main>hello</main>" =?>

85 doc (divWith ("", [], [("role", "main")]) (plain (text "hello")))

86 , test htmlNativeDivs "<main role=X> becomes <div role=X>" $ "<main role=foobar>hello</main>" =?>

87 doc (divWith ("", [], [("role", "foobar")]) (plain (text "hello")))

88 , test htmlNativeDivs "<main> has attributes preserved" $ "<main id=foo class=bar data-baz=qux>hello</main>" =?>

89 doc (divWith ("foo", ["bar"], [("role", "main"), ("baz", "qux")]) (plain (text "hello")))

90 , test htmlNativeDivs "<main> closes <p>" $ "<p>hello<main>main content</main>" =?>

91 doc (para (text "hello") <> divWith ("", [], [("role", "main")]) (plain (text "main content")))

92 , test htmlNativeDivs "<main> followed by text" $ "<main>main content</main>non-main content" =?>

93 doc (divWith ("", [], [("role", "main")]) (plain (text "main content")) <> plain (text "non-main content"))

94 ]

95 , testGroup "samp"

96 [

97 test html "inline samp block" $

98 "<samp>Answer is 42</samp>" =?>

99 plain (codeWith ("",["sample"],[]) "Answer is 42")

100 ]

101 , testGroup "var"

102 [

103 test html "inline var block" $

104 "<var>result</var>" =?>

105 plain (codeWith ("",["variable"],[]) "result")

106 ]

107 , askOption $ \(QuickCheckTests numtests) ->

108 testProperty "Round trip" $

109 withMaxSuccess (if QuickCheckTests numtests == defaultValue

110 then 25

111 else numtests) roundTrip

112 ]