summaryrefslogtreecommitdiff
path: root/test/Tests
diff options
context:
space:
mode:
authorJesse Rosenthal <jrosenthal@jhu.edu>2018-01-25 15:27:54 -0500
committerJesse Rosenthal <jrosenthal@jhu.edu>2018-01-25 15:29:50 -0500
commit61f80e795d527cb0a8e084395d60bf553ee85c2c (patch)
tree80a986703bda463b527ccf8338b6ff154afe1295 /test/Tests
parent751b5ad010794ec51699bfb89de91b38c85d3297 (diff)
Tests: Abstract powerpoint tests out to OOXML tests.
There is very little pptx-specific in these tests, so we abstract out the basic testing function so it can be used for docx as well. This should allow us to catch some errors in the docx writer that slipped by the roundtrip testing.
Diffstat (limited to 'test/Tests')
-rw-r--r--test/Tests/Writers/OOXML.hs186
-rw-r--r--test/Tests/Writers/Powerpoint.hs177
2 files changed, 188 insertions, 175 deletions
diff --git a/test/Tests/Writers/OOXML.hs b/test/Tests/Writers/OOXML.hs
new file mode 100644
index 000000000..c2601eec8
--- /dev/null
+++ b/test/Tests/Writers/OOXML.hs
@@ -0,0 +1,186 @@
+{-# LANGUAGE PatternGuards #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module Tests.Writers.OOXML (ooxmlTest) where
+
+import Text.Pandoc
+import Test.Tasty
+import Test.Tasty.Golden.Advanced
+import Codec.Archive.Zip
+import Text.XML.Light
+import qualified Data.ByteString as BS
+import qualified Data.ByteString.Lazy as BL
+import qualified Data.Text.IO as T
+import Data.List (isSuffixOf, sort, (\\), intercalate, union)
+import Data.Maybe (catMaybes, mapMaybe)
+import Tests.Helpers
+import Data.Algorithm.Diff
+import System.FilePath.Glob (compile, match)
+
+compareXMLBool :: Content -> Content -> Bool
+-- We make a special exception for times at the moment, and just pass
+-- them because we can't control the utctime when running IO. Besides,
+-- so long as we have two times, we're okay.
+compareXMLBool (Elem myElem) (Elem goodElem)
+ | (QName "created" _ (Just "dcterms")) <- elName myElem
+ , (QName "created" _ (Just "dcterms")) <- elName goodElem =
+ True
+compareXMLBool (Elem myElem) (Elem goodElem)
+ | (QName "modified" _ (Just "dcterms")) <- elName myElem
+ , (QName "modified" _ (Just "dcterms")) <- elName goodElem =
+ True
+compareXMLBool (Elem myElem) (Elem goodElem) =
+ elName myElem == elName goodElem &&
+ elAttribs myElem == elAttribs goodElem &&
+ and (zipWith compareXMLBool (elContent myElem) (elContent goodElem))
+
+compareXMLBool (Text myCData) (Text goodCData) =
+ cdVerbatim myCData == cdVerbatim goodCData &&
+ cdData myCData == cdData goodCData &&
+ cdLine myCData == cdLine goodCData
+
+compareXMLBool (CRef myStr) (CRef goodStr) =
+ myStr == goodStr
+compareXMLBool _ _ = False
+
+displayDiff :: Content -> Content -> String
+displayDiff elemA elemB =
+ showDiff (1,1) $ getDiff (lines $ ppContent elemA) (lines $ ppContent elemB)
+
+goldenArchive :: FilePath -> IO Archive
+goldenArchive fp = (toArchive . BL.fromStrict) <$> BS.readFile fp
+
+testArchive :: (WriterOptions -> Pandoc -> PandocIO BL.ByteString)
+ -> WriterOptions
+ -> FilePath
+ -> IO Archive
+testArchive writerFn opts fp = do
+ txt <- T.readFile fp
+ bs <- runIOorExplode $ readNative def txt >>= writerFn opts
+ return $ toArchive bs
+
+compareFileList :: FilePath -> Archive -> Archive -> Maybe String
+compareFileList goldenFP goldenArch testArch =
+ let testFiles = filesInArchive testArch
+ goldenFiles = filesInArchive goldenArch
+ diffTestGolden = testFiles \\ goldenFiles
+ diffGoldenTest = goldenFiles \\ testFiles
+
+ results =
+ [ if null diffGoldenTest
+ then Nothing
+ else Just $
+ "Files in " ++ goldenFP ++ " but not in generated archive:\n" ++
+ intercalate ", " diffGoldenTest
+ , if null diffTestGolden
+ then Nothing
+ else Just $
+ "Files in generated archive but not in " ++ goldenFP ++ ":\n" ++
+ intercalate ", " diffTestGolden
+ ]
+ in
+ if null $ catMaybes results
+ then Nothing
+ else Just $ intercalate "\n" $ catMaybes results
+
+compareXMLFile' :: FilePath -> Archive -> Archive -> Either String ()
+compareXMLFile' fp goldenArch testArch = do
+ testEntry <- case findEntryByPath fp testArch of
+ Just entry -> Right entry
+ Nothing -> Left $
+ "Can't extract " ++ fp ++ " from generated archive"
+ testXMLDoc <- case parseXMLDoc $ fromEntry testEntry of
+ Just doc -> Right doc
+ Nothing -> Left $
+ "Can't parse xml in " ++ fp ++ " from generated archive"
+
+ goldenEntry <- case findEntryByPath fp goldenArch of
+ Just entry -> Right entry
+ Nothing -> Left $
+ "Can't extract " ++ fp ++ " from archive in stored file"
+ goldenXMLDoc <- case parseXMLDoc $ fromEntry goldenEntry of
+ Just doc -> Right doc
+ Nothing -> Left $
+ "Can't parse xml in " ++ fp ++ " from archive in stored file"
+
+ let testContent = Elem testXMLDoc
+ goldenContent = Elem goldenXMLDoc
+
+ if compareXMLBool goldenContent testContent
+ then Right ()
+ else Left $
+ "Non-matching xml in " ++ fp ++ ":\n" ++ displayDiff testContent goldenContent
+
+compareXMLFile :: FilePath -> Archive -> Archive -> Maybe String
+compareXMLFile fp goldenArch testArch =
+ case compareXMLFile' fp goldenArch testArch of
+ Right _ -> Nothing
+ Left s -> Just s
+
+compareAllXMLFiles :: Archive -> Archive -> Maybe String
+compareAllXMLFiles goldenArch testArch =
+ let allFiles = filesInArchive goldenArch `union` filesInArchive testArch
+ allXMLFiles = sort $
+ filter
+ (\fp -> ".xml" `isSuffixOf` fp || ".rels" `isSuffixOf` fp)
+ allFiles
+ results =
+ mapMaybe (\fp -> compareXMLFile fp goldenArch testArch) allXMLFiles
+ in
+ if null results
+ then Nothing
+ else Just $ unlines results
+
+compareMediaFile' :: FilePath -> Archive -> Archive -> Either String ()
+compareMediaFile' fp goldenArch testArch = do
+ testEntry <- case findEntryByPath fp testArch of
+ Just entry -> Right entry
+ Nothing -> Left $
+ "Can't extract " ++ fp ++ " from generated archive"
+ goldenEntry <- case findEntryByPath fp goldenArch of
+ Just entry -> Right entry
+ Nothing -> Left $
+ "Can't extract " ++ fp ++ " from archive in stored file"
+
+ if fromEntry testEntry == fromEntry goldenEntry
+ then Right ()
+ else Left $
+ "Non-matching binary file: " ++ fp
+
+compareMediaFile :: FilePath -> Archive -> Archive -> Maybe String
+compareMediaFile fp goldenArch testArch =
+ case compareMediaFile' fp goldenArch testArch of
+ Right _ -> Nothing
+ Left s -> Just s
+
+compareAllMediaFiles :: Archive -> Archive -> Maybe String
+compareAllMediaFiles goldenArch testArch =
+ let allFiles = filesInArchive goldenArch `union` filesInArchive testArch
+ mediaPattern = compile "*/media/*"
+ allMediaFiles = sort $
+ filter (match mediaPattern) allFiles
+ results =
+ mapMaybe (\fp -> compareMediaFile fp goldenArch testArch) allMediaFiles
+ in
+ if null results
+ then Nothing
+ else Just $ unlines results
+
+ooxmlTest :: (WriterOptions -> Pandoc -> PandocIO BL.ByteString)
+ -> String
+ -> WriterOptions
+ -> FilePath
+ -> FilePath
+ -> TestTree
+ooxmlTest writerFn testName opts nativeFP goldenFP =
+ goldenTest
+ testName
+ (goldenArchive goldenFP)
+ (testArchive writerFn opts nativeFP)
+ (\goldenArch testArch ->
+ let res = catMaybes [ compareFileList goldenFP goldenArch testArch
+ , compareAllXMLFiles goldenArch testArch
+ , compareAllMediaFiles goldenArch testArch
+ ]
+ in return $ if null res then Nothing else Just $ unlines res)
+ (\a -> BL.writeFile goldenFP $ fromArchive a)
diff --git a/test/Tests/Writers/Powerpoint.hs b/test/Tests/Writers/Powerpoint.hs
index 4f14de819..7b21b9e74 100644
--- a/test/Tests/Writers/Powerpoint.hs
+++ b/test/Tests/Writers/Powerpoint.hs
@@ -1,184 +1,11 @@
-{-# LANGUAGE PatternGuards #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE MultiWayIf #-}
-
module Tests.Writers.Powerpoint (tests) where
+import Tests.Writers.OOXML (ooxmlTest)
import Text.Pandoc
import Test.Tasty
-import Test.Tasty.Golden.Advanced
-import Codec.Archive.Zip
-import Text.XML.Light
-import qualified Data.ByteString as BS
-import qualified Data.ByteString.Lazy as BL
-import qualified Data.Text.IO as T
-import Data.List (isPrefixOf, isSuffixOf, sort, (\\), intercalate, union)
-import Data.Maybe (catMaybes, mapMaybe)
-import Tests.Helpers
-import Data.Algorithm.Diff
-
-compareXMLBool :: Content -> Content -> Bool
--- We make a special exception for times at the moment, and just pass
--- them because we can't control the utctime when running IO. Besides,
--- so long as we have two times, we're okay.
-compareXMLBool (Elem myElem) (Elem goodElem)
- | (QName "created" _ (Just "dcterms")) <- elName myElem
- , (QName "created" _ (Just "dcterms")) <- elName goodElem =
- True
-compareXMLBool (Elem myElem) (Elem goodElem)
- | (QName "modified" _ (Just "dcterms")) <- elName myElem
- , (QName "modified" _ (Just "dcterms")) <- elName goodElem =
- True
-compareXMLBool (Elem myElem) (Elem goodElem) =
- elName myElem == elName goodElem &&
- elAttribs myElem == elAttribs goodElem &&
- and (zipWith compareXMLBool (elContent myElem) (elContent goodElem))
-
-compareXMLBool (Text myCData) (Text goodCData) =
- cdVerbatim myCData == cdVerbatim goodCData &&
- cdData myCData == cdData goodCData &&
- cdLine myCData == cdLine goodCData
-
-compareXMLBool (CRef myStr) (CRef goodStr) =
- myStr == goodStr
-compareXMLBool _ _ = False
-
-displayDiff :: Content -> Content -> String
-displayDiff elemA elemB =
- showDiff (1,1) $ getDiff (lines $ ppContent elemA) (lines $ ppContent elemB)
-
-goldenArchive :: FilePath -> IO Archive
-goldenArchive fp = (toArchive . BL.fromStrict) <$> BS.readFile fp
-
-testArchive :: WriterOptions -> FilePath -> IO Archive
-testArchive opts fp = do
- txt <- T.readFile fp
- bs <- runIOorExplode $ readNative def txt >>= writePowerpoint opts
- return $ toArchive bs
-
-compareFileList :: FilePath -> Archive -> Archive -> Maybe String
-compareFileList goldenFP goldenArch testArch =
- let testFiles = filesInArchive testArch
- goldenFiles = filesInArchive goldenArch
- diffTestGolden = testFiles \\ goldenFiles
- diffGoldenTest = goldenFiles \\ testFiles
-
- results =
- [ if null diffGoldenTest
- then Nothing
- else Just $
- "Files in " ++ goldenFP ++ " but not in generated archive:\n" ++
- intercalate ", " diffGoldenTest
- , if null diffTestGolden
- then Nothing
- else Just $
- "Files in generated archive but not in " ++ goldenFP ++ ":\n" ++
- intercalate ", " diffTestGolden
- ]
- in
- if null $ catMaybes results
- then Nothing
- else Just $ intercalate "\n" $ catMaybes results
-
-compareXMLFile' :: FilePath -> Archive -> Archive -> Either String ()
-compareXMLFile' fp goldenArch testArch = do
- testEntry <- case findEntryByPath fp testArch of
- Just entry -> Right entry
- Nothing -> Left $
- "Can't extract " ++ fp ++ " from generated archive"
- testXMLDoc <- case parseXMLDoc $ fromEntry testEntry of
- Just doc -> Right doc
- Nothing -> Left $
- "Can't parse xml in " ++ fp ++ " from generated archive"
-
- goldenEntry <- case findEntryByPath fp goldenArch of
- Just entry -> Right entry
- Nothing -> Left $
- "Can't extract " ++ fp ++ " from archive in stored pptx file"
- goldenXMLDoc <- case parseXMLDoc $ fromEntry goldenEntry of
- Just doc -> Right doc
- Nothing -> Left $
- "Can't parse xml in " ++ fp ++ " from archive in stored pptx file"
-
- let testContent = Elem testXMLDoc
- goldenContent = Elem goldenXMLDoc
-
- if compareXMLBool goldenContent testContent
- then Right ()
- else Left $
- "Non-matching xml in " ++ fp ++ ":\n" ++ displayDiff testContent goldenContent
-
-compareXMLFile :: FilePath -> Archive -> Archive -> Maybe String
-compareXMLFile fp goldenArch testArch =
- case compareXMLFile' fp goldenArch testArch of
- Right _ -> Nothing
- Left s -> Just s
-
-compareAllXMLFiles :: Archive -> Archive -> Maybe String
-compareAllXMLFiles goldenArch testArch =
- let allFiles = filesInArchive goldenArch `union` filesInArchive testArch
- allXMLFiles = sort $
- filter
- (\fp -> ".xml" `isSuffixOf` fp || ".rels" `isSuffixOf` fp)
- allFiles
- results =
- mapMaybe (\fp -> compareXMLFile fp goldenArch testArch) allXMLFiles
- in
- if null results
- then Nothing
- else Just $ unlines results
-
-compareMediaFile' :: FilePath -> Archive -> Archive -> Either String ()
-compareMediaFile' fp goldenArch testArch = do
- testEntry <- case findEntryByPath fp testArch of
- Just entry -> Right entry
- Nothing -> Left $
- "Can't extract " ++ fp ++ " from generated archive"
- goldenEntry <- case findEntryByPath fp goldenArch of
- Just entry -> Right entry
- Nothing -> Left $
- "Can't extract " ++ fp ++ " from archive in stored pptx file"
-
- if fromEntry testEntry == fromEntry goldenEntry
- then Right ()
- else Left $
- "Non-matching binary file: " ++ fp
-
-compareMediaFile :: FilePath -> Archive -> Archive -> Maybe String
-compareMediaFile fp goldenArch testArch =
- case compareMediaFile' fp goldenArch testArch of
- Right _ -> Nothing
- Left s -> Just s
-
-compareAllMediaFiles :: Archive -> Archive -> Maybe String
-compareAllMediaFiles goldenArch testArch =
- let allFiles = filesInArchive goldenArch `union` filesInArchive testArch
- allMediaFiles = sort $
- filter
- (\fp -> "/ppt/media/" `isPrefixOf` fp)
- allFiles
- results =
- mapMaybe (\fp -> compareMediaFile fp goldenArch testArch) allMediaFiles
- in
- if null results
- then Nothing
- else Just $ unlines results
pptxTest :: String -> WriterOptions -> FilePath -> FilePath -> TestTree
-pptxTest testName opts nativeFP goldenFP =
- goldenTest
- testName
- (goldenArchive goldenFP)
- (testArchive opts nativeFP)
- (\goldenArch testArch ->
- let res = catMaybes [ compareFileList goldenFP goldenArch testArch
- , compareAllXMLFiles goldenArch testArch
- , compareAllMediaFiles goldenArch testArch
- ]
- in return $ if null res then Nothing else Just $ unlines res)
- (\a -> BL.writeFile goldenFP $ fromArchive a)
-
---------------------------------------------------------------
+pptxTest = ooxmlTest writePowerpoint
tests :: [TestTree]
tests = [ pptxTest