@@ -1,169 +1,196 @@
1+{-# LANGUAGE PatternGuards #-}
1{-# LANGUAGE OverloadedStrings #-}
2{-# LANGUAGE OverloadedStrings #-}
3+{-# LANGUAGE MultiWayIf #-}
3module Tests.Writers.Powerpoint (tests) where
5module Tests.Writers.Powerpoint (tests) where
5−import Control.Exception (throwIO)
7+-- import Control.Exception (throwIO)
6import Text.Pandoc
8import Text.Pandoc
7−import Text.Pandoc.Builder
8−import Text.Pandoc.Arbitrary ()
9−import Text.Pandoc.Walk
10import Test.Tasty
9import Test.Tasty
11import Test.Tasty.HUnit
10import Test.Tasty.HUnit
12−import Test.Tasty.QuickCheck
13import Codec.Archive.Zip
11import Codec.Archive.Zip
14import Text.XML.Light
12import Text.XML.Light
13+import qualified Data.ByteString.Lazy as BL
14+import qualified Data.Text.IO as T
15−import Data.List (isPrefixOf, isSuffixOf, sort)
15+import Data.List (isPrefixOf, isSuffixOf, sort, (\\), intercalate)
16−import Data.Maybe (mapMaybe)
16+import Data.Maybe (fromJust, isNothing)
17−
17+import Tests.Helpers
18−getPptxArchive :: WriterOptions -> Pandoc -> IO Archive
18+import Data.Algorithm.Diff
19−getPptxArchive opts pd = do
19+import Control.Monad (when)
21− do setUserDataDir $ Just "../data"
21+
22+getPptxBytes :: WriterOptions
25+ -> IO (BL.ByteString, BL.ByteString)
26+getPptxBytes opts nativeFp pptxFp = do
27+ ntvTxt <- T.readFile nativeFp
28+ ntv <- runIOorExplode $ readNative def ntvTxt
22− writePowerpoint opts pd
29+ myPptxBs <- runIOorExplode $ writePowerpoint opts ntv
23− case mbs of
30+ goodPptxBs <- BL.readFile pptxFp
24− Left e -> throwIO e
31+ return (myPptxBs, goodPptxBs)
25− Right bs -> return $ toArchive bs
32+
27−----- Number of Slides -----------
34+assertSameFileList :: Archive -> Archive -> FilePath -> Assertion
28−
35+assertSameFileList myArch goodArch pptxFp = do
29−numberOfSlides :: WriterOptions -> Pandoc -> IO Int
36+ let filesMy = filesInArchive myArch
30−numberOfSlides opts pd = do
37+ filesGood = filesInArchive goodArch
31− archive <- getPptxArchive opts pd
38+ diffMyGood = filesMy \\ filesGood
32− return $
39+ diffGoodMy = filesGood \\ filesMy
33− length $
40+ if | null diffMyGood && null diffGoodMy -> return ()
34− filter (isSuffixOf ".xml") $
41+ | null diffMyGood ->
35− filter (isPrefixOf "ppt/slides/slide") $
42+ assertFailure $
36− filesInArchive archive
43+ "Files in " ++ pptxFp ++ " but not in generated archive:\n" ++
37−
44+ intercalate ", " diffGoodMy
38−testNumberOfSlides :: TestName -> Int -> WriterOptions -> Pandoc -> TestTree
45+ | null diffGoodMy ->
39−testNumberOfSlides name n opts pd =
46+ assertFailure $
40− testCase name $ do
47+ "Files in generated archive but not in " ++ pptxFp ++ ":\n" ++
41− n' <- numberOfSlides opts pd
48+ intercalate ", " diffMyGood
42− n' @=? n
49+ | otherwise ->
44−numSlideTests :: TestTree
51+ "Files in " ++ pptxFp ++ " but not in generated archive:\n" ++
45−numSlideTests = testGroup "Number of slides in output"
52+ intercalate ", " diffGoodMy ++
46− [ testNumberOfSlides
53+ "\n" ++
47− "simple one-slide deck" 1
54+ "Files in generated archive but not in " ++ pptxFp ++ ":\n" ++
48− def
55+ intercalate ", " diffMyGood
49− (doc $ para "foo")
56+
50− , testNumberOfSlides
57+compareXMLBool :: Content -> Content -> Bool
51− "with metadata (header slide)" 2
58+-- We make a special exception for times at the moment, and just pass
52− def
59+-- them because we can't control the utctime when running IO. Besides,
53− (setTitle "My Title" $ doc $ para "foo")
60+-- so long as we have two times, we're okay.
54− , testNumberOfSlides
61+compareXMLBool (Elem myElem) (Elem goodElem)
55− "With h1 slide (using default slide-level)" 1
62+ | (QName "created" _ (Just "dcterms")) <- elName myElem
56− def
63+ , (QName "created" _ (Just "dcterms")) <- elName goodElem =
57− (doc $ header 1 "Header" <> para "foo")
64+ True
58− , testNumberOfSlides
65+compareXMLBool (Elem myElem) (Elem goodElem)
59− "With h2 slide (using default slide-level)" 2
66+ | (QName "modified" _ (Just "dcterms")) <- elName myElem
60− def
67+ , (QName "modified" _ (Just "dcterms")) <- elName goodElem =
61− (doc $ header 1 "Header" <> header 2 "subeader" <> para "foo")
68+ True
62− , testNumberOfSlides
69+compareXMLBool (Elem myElem) (Elem goodElem) =
63− "With h1 slide (using slide-level 3)" 2
70+ and [ elName myElem == elName goodElem
64− def {writerSlideLevel= Just 3}
71+ , elAttribs myElem == elAttribs goodElem
65− (doc $ header 1 "Header" <> para "foo")
72+ , and $
66− , testNumberOfSlides
73+ map (uncurry compareXMLBool) $
67− "With h2 slide (using slide-level 3)" 3
74+ zip (elContent myElem) (elContent goodElem)
68− def {writerSlideLevel= Just 3}
75+ ]
69− (doc $ header 1 "Header" <> header 2 "subeader" <> para "foo")
76+compareXMLBool (Text myCData) (Text goodCData) =
70− , testNumberOfSlides
77+ and [ cdVerbatim myCData == cdVerbatim goodCData
71− "With image slide, no header" 3
78+ , cdData myCData == cdData goodCData
72− def
79+ , cdLine myCData == cdLine goodCData
74− para "first slide" <>
81+compareXMLBool (CRef myStr) (CRef goodStr) =
75− para (image "lalune.jpg" "" "") <>
82+ myStr == goodStr
76− para "foo")
83+compareXMLBool _ _ = False
77− , testNumberOfSlides
84+
78− "With image slide, header" 3
85+displayDiff :: Content -> Content -> String
79− def
86+displayDiff elemA elemB =
80− (doc $
87+ showDiff (1,1) $ getDiff (lines $ ppContent elemA) (lines $ ppContent elemB)
81− para "first slide" <>
88+
82− header 2 "image header" <>
89+compareXMLFile :: FilePath -> Archive -> Archive -> Assertion
83− para (image "lalune.jpg" "" "") <>
90+compareXMLFile fp myArch goodArch = do
84− para "foo")
91+ let mbMyEntry = findEntryByPath fp myArch
85− , testNumberOfSlides
92+ when (isNothing mbMyEntry)
86− "With table, no header" 3
93+ (assertFailure $
87− def
94+ "Can't extract " ++ fp ++ " from generated archive")
88− (doc $
95+ let mbMyXMLDoc = parseXMLDoc $ fromEntry $ fromJust mbMyEntry
89− para "first slide" <>
96+ when (isNothing mbMyXMLDoc)
90− simpleTable [para "foo" <> para "bar"] [[para "this" <> para "that"]] <>
97+ (assertFailure $
91− para "foo")
98+ "Can't parse xml in " ++ fp ++ " from generated archive")
92− , testNumberOfSlides
99+ let myContent = Elem $ fromJust mbMyXMLDoc
93− "With table, header" 3
100+
94− def
101+ let mbGoodEntry = findEntryByPath fp goodArch
95− (doc $
102+ when (isNothing mbGoodEntry)
96− para "first slide" <>
103+ (assertFailure $
97− header 2 "table header" <>
104+ "Can't extract " ++ fp ++ " from archive in stored pptx file")
98− simpleTable [para "foo" <> para "bar"] [[para "this" <> para "that"]] <>
105+ let mbGoodXMLDoc = parseXMLDoc $ fromEntry $ fromJust mbGoodEntry
99− para "foo")
106+ when (isNothing mbGoodXMLDoc)
100− , testNumberOfSlides
107+ (assertFailure $
101− "hrule" 2
108+ "Can't parse xml in " ++ fp ++ " from archive in stored pptx file")
102− def
109+ let goodContent = Elem $ fromJust mbGoodXMLDoc
104− para "first slide" <> horizontalRule <> para "last slide")
111+ assertBool
105− , testNumberOfSlides
112+ ("Non-matching xml in " ++ fp ++ ":\n" ++ displayDiff myContent goodContent)
106− "with notes slide" 2
113+ (compareXMLBool myContent goodContent)
108− (doc $
115+compareBinaryFile :: FilePath -> Archive -> Archive -> Assertion
109− para $ text "Foo" <> note (para "note text"))
116+compareBinaryFile fp myArch goodArch = do
110− ]
117+ let mbMyEntry = findEntryByPath fp myArch
111−
118+ when (isNothing mbMyEntry)
112−----- Content Types -----------
119+ (assertFailure $
113−
120+ "Can't extract " ++ fp ++ " from generated archive")
114−
121+ let myBytes = fromEntry $ fromJust mbMyEntry
115−contentTypesFileExists :: WriterOptions -> Pandoc -> TestTree
122+
116−contentTypesFileExists opts pd =
123+ let mbGoodEntry = findEntryByPath fp goodArch
117− testCase "Existence of [Content_Types].xml file" $
124+ when (isNothing mbGoodEntry)
118− do archive <- getPptxArchive opts pd
125+ (assertFailure $
119− assertBool "Missing [Content_Types].xml file" $
126+ "Can't extract " ++ fp ++ " from archive in stored pptx file")
120− "[Content_Types].xml" `elem` filesInArchive archive
127+ let goodBytes = fromEntry $ fromJust mbGoodEntry
122−
129+ assertBool (fp ++ " doesn't match") (myBytes == goodBytes)
124−-- We want an "Override" entry for each xml file under ppt/.
131+testSameFileList :: WriterOptions -> FilePath -> FilePath -> TestTree
125−prop_ContentOverrides :: Pandoc -> IO Bool
132+testSameFileList opts myFp goodFp =
126−prop_ContentOverrides pd = do
133+ testCase ("Identical file list in archives") $ do
127− -- remove Math to avoid warnings
134+ (myBS, goodBS) <- getPptxBytes opts myFp goodFp
128− let go :: Inline -> Inline
135+ let myArch = toArchive myBS
129− go (Math _ _) = Str "Math"
136+ goodArch = toArchive goodBS
130− go i = i
137+ (assertSameFileList myArch goodArch goodFp)
131− pd' = walk go pd
138+
132− archive <- getPptxArchive def pd'
139+testSameXML :: WriterOptions -> FilePath -> FilePath -> TestTree
133− let xmlFiles = filter ("[Content_Types].xml" /=) $
140+testSameXML opts myFp goodFp = testCaseSteps "Comparing extracted xml files" $
134− filter (isSuffixOf ".xml") $
141+ \step -> do
135− filesInArchive archive
142+ (myBS, goodBS) <- getPptxBytes opts myFp goodFp
136− contentTypes <- case findEntryByPath "[Content_Types].xml" archive of
143+ let myArch = toArchive myBS
137− Just ent -> return $ fromEntry ent
144+ goodArch = toArchive goodBS
138− Nothing -> throwIO $
145+
139− PandocSomeError "Missing [Content_Types].xml file"
146+ let xmlFileList = sort $
140− typesElem <- case parseXMLDoc contentTypes of
147+ filter (\fp -> ".xml" `isSuffixOf` fp || ".rels" `isSuffixOf` fp)
141− Just element -> return element
148+ (filesInArchive myArch)
142− Nothing -> throwIO $
149+ mapM_
143− PandocSomeError "[Content_Types].xml cannot be parsed"
150+ (\fp -> step ("- " ++ fp) >> compareXMLFile fp myArch goodArch)
144− let ns = findAttr (QName "xmlns" Nothing Nothing) typesElem
151+ xmlFileList
145− overrides = findChildren (QName "Override" ns Nothing) typesElem
152+
146− partNames = mapMaybe (findAttr (QName "PartName" Nothing Nothing)) overrides
153+testSameMedia :: WriterOptions -> FilePath -> FilePath -> TestTree
147− -- files in content_types are absolute
154+testSameMedia opts myFp goodFp = testCaseSteps "Comparing media files" $
148− absXmlFiles = map (\fp -> case fp of
155+ \step -> do
149− ('/':_) -> fp
156+ (myBS, goodBS) <- getPptxBytes opts myFp goodFp
150− _ -> '/': fp
157+ let myArch = toArchive myBS
151− )
158+ goodArch = toArchive goodBS
153− return $ sort absXmlFiles == sort partNames
160+ let mediaFileList = sort $
154−
161+ filter (\fp -> "ppt/media/" `isPrefixOf` fp)
155−contentOverridesTests :: TestTree
162+ (filesInArchive myArch)
156−contentOverridesTests = localOption (QuickCheckTests 20) $
163+
157− testProperty "Content Overrides for each XML file" $
164+ mapM_
158− \x -> ioProperty $ prop_ContentOverrides (x :: Pandoc)
165+ (\fp -> step ("- " ++ fp) >> compareBinaryFile fp myArch goodArch)
160−contentTypeTests :: TestTree
167+
161−contentTypeTests = testGroup "[Content_Types].xml file"
168+testCompareWithOpts :: String -> WriterOptions ->FilePath -> FilePath -> TestTree
162− [ contentTypesFileExists def (doc $ para "foo")
169+testCompareWithOpts testName opts nativeFp pptxFp =
163− , contentOverridesTests
170+ testGroup testName [ testSameFileList opts nativeFp pptxFp
164− ]
171+ , testSameXML opts nativeFp pptxFp
172+ , testSameMedia opts nativeFp pptxFp
176+testCompare :: String -> FilePath -> FilePath -> TestTree
177+testCompare testName nativeFp pptxFp =
178+ testCompareWithOpts testName def nativeFp pptxFp
180+--------------------------------------------------------------
166tests :: [TestTree]
182tests :: [TestTree]
167−tests = [ numSlideTests
183+tests = [ testCompare
168− , contentTypeTests
184+ "Inline formatting"
185+ "pptx/inline_formatting.native"
186+ "pptx/inline_formatting.pptx"
188+ "slide breaks (default slide-level)"
189+ "pptx/slide_breaks.native"
190+ "pptx/slide_breaks.pptx"
191+ , testCompareWithOpts
192+ "slide breaks (slide-level set to 1)"
193+ def{writerSlideLevel=Just 1}
194+ "pptx/slide_breaks.native"
195+ "pptx/slide_breaks_slide_level_1.pptx"