aboutsummaryrefslogtreecommitdiff
path: root/test
diff options
context:
space:
mode:
Diffstat (limited to 'test')
-rw-r--r--test/Tests/Writers/Powerpoint.hs341
-rw-r--r--test/pptx/inline_formatting.native5
-rw-r--r--test/pptx/inline_formatting.pptxbin0 -> 25582 bytes
-rw-r--r--test/pptx/slide_breaks.native7
-rw-r--r--test/pptx/slide_breaks.pptxbin0 -> 28032 bytes
-rw-r--r--test/pptx/slide_breaks_slide_level_1.pptxbin0 -> 27202 bytes
6 files changed, 196 insertions, 157 deletions
diff --git a/test/Tests/Writers/Powerpoint.hs b/test/Tests/Writers/Powerpoint.hs
index e179742ed..139081013 100644
--- a/test/Tests/Writers/Powerpoint.hs
+++ b/test/Tests/Writers/Powerpoint.hs
@@ -1,169 +1,196 @@
+{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE MultiWayIf #-}
module Tests.Writers.Powerpoint (tests) where
-import Control.Exception (throwIO)
+-- import Control.Exception (throwIO)
import Text.Pandoc
-import Text.Pandoc.Builder
-import Text.Pandoc.Arbitrary ()
-import Text.Pandoc.Walk
import Test.Tasty
import Test.Tasty.HUnit
-import Test.Tasty.QuickCheck
import Codec.Archive.Zip
import Text.XML.Light
-import Data.List (isPrefixOf, isSuffixOf, sort)
-import Data.Maybe (mapMaybe)
-
-getPptxArchive :: WriterOptions -> Pandoc -> IO Archive
-getPptxArchive opts pd = do
- mbs <- runIO $
- do setUserDataDir $ Just "../data"
- writePowerpoint opts pd
- case mbs of
- Left e -> throwIO e
- Right bs -> return $ toArchive bs
-
------ Number of Slides -----------
-
-numberOfSlides :: WriterOptions -> Pandoc -> IO Int
-numberOfSlides opts pd = do
- archive <- getPptxArchive opts pd
- return $
- length $
- filter (isSuffixOf ".xml") $
- filter (isPrefixOf "ppt/slides/slide") $
- filesInArchive archive
-
-testNumberOfSlides :: TestName -> Int -> WriterOptions -> Pandoc -> TestTree
-testNumberOfSlides name n opts pd =
- testCase name $ do
- n' <- numberOfSlides opts pd
- n' @=? n
-
-numSlideTests :: TestTree
-numSlideTests = testGroup "Number of slides in output"
- [ testNumberOfSlides
- "simple one-slide deck" 1
- def
- (doc $ para "foo")
- , testNumberOfSlides
- "with metadata (header slide)" 2
- def
- (setTitle "My Title" $ doc $ para "foo")
- , testNumberOfSlides
- "With h1 slide (using default slide-level)" 1
- def
- (doc $ header 1 "Header" <> para "foo")
- , testNumberOfSlides
- "With h2 slide (using default slide-level)" 2
- def
- (doc $ header 1 "Header" <> header 2 "subeader" <> para "foo")
- , testNumberOfSlides
- "With h1 slide (using slide-level 3)" 2
- def {writerSlideLevel= Just 3}
- (doc $ header 1 "Header" <> para "foo")
- , testNumberOfSlides
- "With h2 slide (using slide-level 3)" 3
- def {writerSlideLevel= Just 3}
- (doc $ header 1 "Header" <> header 2 "subeader" <> para "foo")
- , testNumberOfSlides
- "With image slide, no header" 3
- def
- (doc $
- para "first slide" <>
- para (image "lalune.jpg" "" "") <>
- para "foo")
- , testNumberOfSlides
- "With image slide, header" 3
- def
- (doc $
- para "first slide" <>
- header 2 "image header" <>
- para (image "lalune.jpg" "" "") <>
- para "foo")
- , testNumberOfSlides
- "With table, no header" 3
- def
- (doc $
- para "first slide" <>
- simpleTable [para "foo" <> para "bar"] [[para "this" <> para "that"]] <>
- para "foo")
- , testNumberOfSlides
- "With table, header" 3
- def
- (doc $
- para "first slide" <>
- header 2 "table header" <>
- simpleTable [para "foo" <> para "bar"] [[para "this" <> para "that"]] <>
- para "foo")
- , testNumberOfSlides
- "hrule" 2
- def
- (doc $
- para "first slide" <> horizontalRule <> para "last slide")
- , testNumberOfSlides
- "with notes slide" 2
- def
- (doc $
- para $ text "Foo" <> note (para "note text"))
- ]
-
------ Content Types -----------
-
-
-contentTypesFileExists :: WriterOptions -> Pandoc -> TestTree
-contentTypesFileExists opts pd =
- testCase "Existence of [Content_Types].xml file" $
- do archive <- getPptxArchive opts pd
- assertBool "Missing [Content_Types].xml file" $
- "[Content_Types].xml" `elem` filesInArchive archive
-
-
-
--- We want an "Override" entry for each xml file under ppt/.
-prop_ContentOverrides :: Pandoc -> IO Bool
-prop_ContentOverrides pd = do
- -- remove Math to avoid warnings
- let go :: Inline -> Inline
- go (Math _ _) = Str "Math"
- go i = i
- pd' = walk go pd
- archive <- getPptxArchive def pd'
- let xmlFiles = filter ("[Content_Types].xml" /=) $
- filter (isSuffixOf ".xml") $
- filesInArchive archive
- contentTypes <- case findEntryByPath "[Content_Types].xml" archive of
- Just ent -> return $ fromEntry ent
- Nothing -> throwIO $
- PandocSomeError "Missing [Content_Types].xml file"
- typesElem <- case parseXMLDoc contentTypes of
- Just element -> return element
- Nothing -> throwIO $
- PandocSomeError "[Content_Types].xml cannot be parsed"
- let ns = findAttr (QName "xmlns" Nothing Nothing) typesElem
- overrides = findChildren (QName "Override" ns Nothing) typesElem
- partNames = mapMaybe (findAttr (QName "PartName" Nothing Nothing)) overrides
- -- files in content_types are absolute
- absXmlFiles = map (\fp -> case fp of
- ('/':_) -> fp
- _ -> '/': fp
- )
- xmlFiles
- return $ sort absXmlFiles == sort partNames
-
-contentOverridesTests :: TestTree
-contentOverridesTests = localOption (QuickCheckTests 20) $
- testProperty "Content Overrides for each XML file" $
- \x -> ioProperty $ prop_ContentOverrides (x :: Pandoc)
-
-contentTypeTests :: TestTree
-contentTypeTests = testGroup "[Content_Types].xml file"
- [ contentTypesFileExists def (doc $ para "foo")
- , contentOverridesTests
- ]
+import qualified Data.ByteString.Lazy as BL
+import qualified Data.Text.IO as T
+import Data.List (isPrefixOf, isSuffixOf, sort, (\\), intercalate)
+import Data.Maybe (fromJust, isNothing)
+import Tests.Helpers
+import Data.Algorithm.Diff
+import Control.Monad (when)
+
+
+getPptxBytes :: WriterOptions
+ -> FilePath
+ -> FilePath
+ -> IO (BL.ByteString, BL.ByteString)
+getPptxBytes opts nativeFp pptxFp = do
+ ntvTxt <- T.readFile nativeFp
+ ntv <- runIOorExplode $ readNative def ntvTxt
+ myPptxBs <- runIOorExplode $ writePowerpoint opts ntv
+ goodPptxBs <- BL.readFile pptxFp
+ return (myPptxBs, goodPptxBs)
+
+
+assertSameFileList :: Archive -> Archive -> FilePath -> Assertion
+assertSameFileList myArch goodArch pptxFp = do
+ let filesMy = filesInArchive myArch
+ filesGood = filesInArchive goodArch
+ diffMyGood = filesMy \\ filesGood
+ diffGoodMy = filesGood \\ filesMy
+ if | null diffMyGood && null diffGoodMy -> return ()
+ | null diffMyGood ->
+ assertFailure $
+ "Files in " ++ pptxFp ++ " but not in generated archive:\n" ++
+ intercalate ", " diffGoodMy
+ | null diffGoodMy ->
+ assertFailure $
+ "Files in generated archive but not in " ++ pptxFp ++ ":\n" ++
+ intercalate ", " diffMyGood
+ | otherwise ->
+ assertFailure $
+ "Files in " ++ pptxFp ++ " but not in generated archive:\n" ++
+ intercalate ", " diffGoodMy ++
+ "\n" ++
+ "Files in generated archive but not in " ++ pptxFp ++ ":\n" ++
+ intercalate ", " diffMyGood
+
+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) =
+ and [ elName myElem == elName goodElem
+ , elAttribs myElem == elAttribs goodElem
+ , and $
+ map (uncurry compareXMLBool) $
+ zip (elContent myElem) (elContent goodElem)
+ ]
+compareXMLBool (Text myCData) (Text goodCData) =
+ and [ 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)
+
+compareXMLFile :: FilePath -> Archive -> Archive -> Assertion
+compareXMLFile fp myArch goodArch = do
+ let mbMyEntry = findEntryByPath fp myArch
+ when (isNothing mbMyEntry)
+ (assertFailure $
+ "Can't extract " ++ fp ++ " from generated archive")
+ let mbMyXMLDoc = parseXMLDoc $ fromEntry $ fromJust mbMyEntry
+ when (isNothing mbMyXMLDoc)
+ (assertFailure $
+ "Can't parse xml in " ++ fp ++ " from generated archive")
+ let myContent = Elem $ fromJust mbMyXMLDoc
+
+ let mbGoodEntry = findEntryByPath fp goodArch
+ when (isNothing mbGoodEntry)
+ (assertFailure $
+ "Can't extract " ++ fp ++ " from archive in stored pptx file")
+ let mbGoodXMLDoc = parseXMLDoc $ fromEntry $ fromJust mbGoodEntry
+ when (isNothing mbGoodXMLDoc)
+ (assertFailure $
+ "Can't parse xml in " ++ fp ++ " from archive in stored pptx file")
+ let goodContent = Elem $ fromJust mbGoodXMLDoc
+
+ assertBool
+ ("Non-matching xml in " ++ fp ++ ":\n" ++ displayDiff myContent goodContent)
+ (compareXMLBool myContent goodContent)
+
+compareBinaryFile :: FilePath -> Archive -> Archive -> Assertion
+compareBinaryFile fp myArch goodArch = do
+ let mbMyEntry = findEntryByPath fp myArch
+ when (isNothing mbMyEntry)
+ (assertFailure $
+ "Can't extract " ++ fp ++ " from generated archive")
+ let myBytes = fromEntry $ fromJust mbMyEntry
+
+ let mbGoodEntry = findEntryByPath fp goodArch
+ when (isNothing mbGoodEntry)
+ (assertFailure $
+ "Can't extract " ++ fp ++ " from archive in stored pptx file")
+ let goodBytes = fromEntry $ fromJust mbGoodEntry
+
+ assertBool (fp ++ " doesn't match") (myBytes == goodBytes)
+
+testSameFileList :: WriterOptions -> FilePath -> FilePath -> TestTree
+testSameFileList opts myFp goodFp =
+ testCase ("Identical file list in archives") $ do
+ (myBS, goodBS) <- getPptxBytes opts myFp goodFp
+ let myArch = toArchive myBS
+ goodArch = toArchive goodBS
+ (assertSameFileList myArch goodArch goodFp)
+
+testSameXML :: WriterOptions -> FilePath -> FilePath -> TestTree
+testSameXML opts myFp goodFp = testCaseSteps "Comparing extracted xml files" $
+ \step -> do
+ (myBS, goodBS) <- getPptxBytes opts myFp goodFp
+ let myArch = toArchive myBS
+ goodArch = toArchive goodBS
+
+ let xmlFileList = sort $
+ filter (\fp -> ".xml" `isSuffixOf` fp || ".rels" `isSuffixOf` fp)
+ (filesInArchive myArch)
+ mapM_
+ (\fp -> step ("- " ++ fp) >> compareXMLFile fp myArch goodArch)
+ xmlFileList
+
+testSameMedia :: WriterOptions -> FilePath -> FilePath -> TestTree
+testSameMedia opts myFp goodFp = testCaseSteps "Comparing media files" $
+ \step -> do
+ (myBS, goodBS) <- getPptxBytes opts myFp goodFp
+ let myArch = toArchive myBS
+ goodArch = toArchive goodBS
+
+ let mediaFileList = sort $
+ filter (\fp -> "ppt/media/" `isPrefixOf` fp)
+ (filesInArchive myArch)
+
+ mapM_
+ (\fp -> step ("- " ++ fp) >> compareBinaryFile fp myArch goodArch)
+ mediaFileList
+
+testCompareWithOpts :: String -> WriterOptions ->FilePath -> FilePath -> TestTree
+testCompareWithOpts testName opts nativeFp pptxFp =
+ testGroup testName [ testSameFileList opts nativeFp pptxFp
+ , testSameXML opts nativeFp pptxFp
+ , testSameMedia opts nativeFp pptxFp
+ ]
+
+
+testCompare :: String -> FilePath -> FilePath -> TestTree
+testCompare testName nativeFp pptxFp =
+ testCompareWithOpts testName def nativeFp pptxFp
+
+--------------------------------------------------------------
tests :: [TestTree]
-tests = [ numSlideTests
- , contentTypeTests
+tests = [ testCompare
+ "Inline formatting"
+ "pptx/inline_formatting.native"
+ "pptx/inline_formatting.pptx"
+ , testCompare
+ "slide breaks (default slide-level)"
+ "pptx/slide_breaks.native"
+ "pptx/slide_breaks.pptx"
+ , testCompareWithOpts
+ "slide breaks (slide-level set to 1)"
+ def{writerSlideLevel=Just 1}
+ "pptx/slide_breaks.native"
+ "pptx/slide_breaks_slide_level_1.pptx"
]
diff --git a/test/pptx/inline_formatting.native b/test/pptx/inline_formatting.native
new file mode 100644
index 000000000..d79220e4f
--- /dev/null
+++ b/test/pptx/inline_formatting.native
@@ -0,0 +1,5 @@
+Pandoc (Meta {unMeta = fromList []})
+[Para [Str "Here",Space,Str "are",Space,Str "examples",Space,Str "of",Space,Emph [Str "italics"],Str ",",Space,Strong [Str "bold"],Str ",",Space,Str "and",Space,Strong [Emph [Str "bold",Space,Str "italics"]],Str "."]
+,Para [Str "Here",Space,Str "is",Space,Strikeout [Str "strook-three"],Space,Str "strike-through",Space,Str "and",Space,SmallCaps [Str "small",Space,Str "caps"],Str "."]
+,Para [Str "We",Space,Str "can",Space,Str "also",Space,Str "do",Space,Str "subscripts",Space,Str "(H",Subscript [Str "2"],Str "0)",Space,Str "and",Space,Str "super",Superscript [Str "script"],Str "."]
+,RawBlock (Format "html") "<!-- Comments don't show up. -->"]
diff --git a/test/pptx/inline_formatting.pptx b/test/pptx/inline_formatting.pptx
new file mode 100644
index 000000000..e128f1bce
--- /dev/null
+++ b/test/pptx/inline_formatting.pptx
Binary files differ
diff --git a/test/pptx/slide_breaks.native b/test/pptx/slide_breaks.native
new file mode 100644
index 000000000..084c61737
--- /dev/null
+++ b/test/pptx/slide_breaks.native
@@ -0,0 +1,7 @@
+Pandoc (Meta {unMeta = fromList []})
+[Para [Str "Break",Space,Str "with",Space,Str "a",Space,Str "new",Space,Str "section-level",Space,Str "header"]
+,Header 1 ("below-section-level",[],[]) [Str "Below",Space,Str "section-level"]
+,Header 2 ("section-level",[],[]) [Str "Section-level"]
+,Para [Str "Third",Space,Str "slide",Space,Str "(with",Space,Str "a",Space,Str "section-level",Space,Str "of",Space,Str "2)"]
+,HorizontalRule
+,Para [Str "This",Space,Str "is",Space,Str "another",Space,Str "slide."]]
diff --git a/test/pptx/slide_breaks.pptx b/test/pptx/slide_breaks.pptx
new file mode 100644
index 000000000..b22b0bc50
--- /dev/null
+++ b/test/pptx/slide_breaks.pptx
Binary files differ
diff --git a/test/pptx/slide_breaks_slide_level_1.pptx b/test/pptx/slide_breaks_slide_level_1.pptx
new file mode 100644
index 000000000..d4d7bc415
--- /dev/null
+++ b/test/pptx/slide_breaks_slide_level_1.pptx
Binary files differ
generated by cgit v1.2.3 (git 2.46.0) at 2025-10-31 04:05:55 +0000