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.
This commit is contained in:
Jesse Rosenthal
parent
751b5ad010
commit
61f80e795d
3 changed files with 191 additions and 176 deletions
|
|
@ -618,7 +618,8 @@ test-suite test-pandoc
|
||||||
containers >= 0.4.2.1 && < 0.6,
|
containers >= 0.4.2.1 && < 0.6,
|
||||||
executable-path >= 0.0 && < 0.1,
|
executable-path >= 0.0 && < 0.1,
|
||||||
zip-archive >= 0.2.3.4 && < 0.4,
|
zip-archive >= 0.2.3.4 && < 0.4,
|
||||||
xml >= 1.3.12 && < 1.4
|
xml >= 1.3.12 && < 1.4,
|
||||||
|
Glob >= 0.7 && < 0.10
|
||||||
if flag(old-locale)
|
if flag(old-locale)
|
||||||
build-depends: old-locale >= 1 && < 1.1,
|
build-depends: old-locale >= 1 && < 1.1,
|
||||||
time >= 1.2 && < 1.5
|
time >= 1.2 && < 1.5
|
||||||
|
|
@ -669,6 +670,7 @@ test-suite test-pandoc
|
||||||
Tests.Writers.Muse
|
Tests.Writers.Muse
|
||||||
Tests.Writers.FB2
|
Tests.Writers.FB2
|
||||||
Tests.Writers.Powerpoint
|
Tests.Writers.Powerpoint
|
||||||
|
Tests.Writers.OOXML
|
||||||
ghc-options: -rtsopts -Wall -fno-warn-unused-do-bind -threaded
|
ghc-options: -rtsopts -Wall -fno-warn-unused-do-bind -threaded
|
||||||
default-language: Haskell98
|
default-language: Haskell98
|
||||||
|
|
||||||
|
|
|
||||||
186
test/Tests/Writers/OOXML.hs
Normal file
186
test/Tests/Writers/OOXML.hs
Normal file
|
|
@ -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)
|
||||||
|
|
@ -1,184 +1,11 @@
|
||||||
{-# LANGUAGE PatternGuards #-}
|
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
|
||||||
{-# LANGUAGE MultiWayIf #-}
|
|
||||||
|
|
||||||
module Tests.Writers.Powerpoint (tests) where
|
module Tests.Writers.Powerpoint (tests) where
|
||||||
|
|
||||||
|
import Tests.Writers.OOXML (ooxmlTest)
|
||||||
import Text.Pandoc
|
import Text.Pandoc
|
||||||
import Test.Tasty
|
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 :: String -> WriterOptions -> FilePath -> FilePath -> TestTree
|
||||||
pptxTest testName opts nativeFP goldenFP =
|
pptxTest = ooxmlTest writePowerpoint
|
||||||
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)
|
|
||||||
|
|
||||||
--------------------------------------------------------------
|
|
||||||
|
|
||||||
tests :: [TestTree]
|
tests :: [TestTree]
|
||||||
tests = [ pptxTest
|
tests = [ pptxTest
|
||||||
|
|
|
||||||
Loading…
Reference in a new issue