@@ -1,184 +1,11 @@
1−{-# LANGUAGE PatternGuards #-}
2−{-# LANGUAGE OverloadedStrings #-}
3−{-# LANGUAGE MultiWayIf #-}
4−
51module Tests.Writers.Powerpoint (tests) where
62
3+import Tests.Writers.OOXML (ooxmlTest)
74import Text.Pandoc
85import Test.Tasty
9−import Test.Tasty.Golden.Advanced
10−import Codec.Archive.Zip
11−import Text.XML.Light
12−import qualified Data.ByteString as BS
13−import qualified Data.ByteString.Lazy as BL
14−import qualified Data.Text.IO as T
15−import Data.List (isPrefixOf, isSuffixOf, sort, (\\), intercalate, union)
16−import Data.Maybe (catMaybes, mapMaybe)
17−import Tests.Helpers
18−import Data.Algorithm.Diff
19−
20−compareXMLBool :: Content -> Content -> Bool
21−-- We make a special exception for times at the moment, and just pass
22−-- them because we can't control the utctime when running IO. Besides,
23−-- so long as we have two times, we're okay.
24−compareXMLBool (Elem myElem) (Elem goodElem)
25− | (QName "created" _ (Just "dcterms")) <- elName myElem
26− , (QName "created" _ (Just "dcterms")) <- elName goodElem =
27− True
28−compareXMLBool (Elem myElem) (Elem goodElem)
29− | (QName "modified" _ (Just "dcterms")) <- elName myElem
30− , (QName "modified" _ (Just "dcterms")) <- elName goodElem =
31− True
32−compareXMLBool (Elem myElem) (Elem goodElem) =
33− elName myElem == elName goodElem &&
34− elAttribs myElem == elAttribs goodElem &&
35− and (zipWith compareXMLBool (elContent myElem) (elContent goodElem))
36−
37−compareXMLBool (Text myCData) (Text goodCData) =
38− cdVerbatim myCData == cdVerbatim goodCData &&
39− cdData myCData == cdData goodCData &&
40− cdLine myCData == cdLine goodCData
41−
42−compareXMLBool (CRef myStr) (CRef goodStr) =
43− myStr == goodStr
44−compareXMLBool _ _ = False
45−
46−displayDiff :: Content -> Content -> String
47−displayDiff elemA elemB =
48− showDiff (1,1) $ getDiff (lines $ ppContent elemA) (lines $ ppContent elemB)
49−
50−goldenArchive :: FilePath -> IO Archive
51−goldenArchive fp = (toArchive . BL.fromStrict) <$> BS.readFile fp
52−
53−testArchive :: WriterOptions -> FilePath -> IO Archive
54−testArchive opts fp = do
55− txt <- T.readFile fp
56− bs <- runIOorExplode $ readNative def txt >>= writePowerpoint opts
57− return $ toArchive bs
58−
59−compareFileList :: FilePath -> Archive -> Archive -> Maybe String
60−compareFileList goldenFP goldenArch testArch =
61− let testFiles = filesInArchive testArch
62− goldenFiles = filesInArchive goldenArch
63− diffTestGolden = testFiles \\ goldenFiles
64− diffGoldenTest = goldenFiles \\ testFiles
65−
66− results =
67− [ if null diffGoldenTest
68− then Nothing
69− else Just $
70− "Files in " ++ goldenFP ++ " but not in generated archive:\n" ++
71− intercalate ", " diffGoldenTest
72− , if null diffTestGolden
73− then Nothing
74− else Just $
75− "Files in generated archive but not in " ++ goldenFP ++ ":\n" ++
76− intercalate ", " diffTestGolden
77− ]
78− in
79− if null $ catMaybes results
80− then Nothing
81− else Just $ intercalate "\n" $ catMaybes results
82−
83−compareXMLFile' :: FilePath -> Archive -> Archive -> Either String ()
84−compareXMLFile' fp goldenArch testArch = do
85− testEntry <- case findEntryByPath fp testArch of
86− Just entry -> Right entry
87− Nothing -> Left $
88− "Can't extract " ++ fp ++ " from generated archive"
89− testXMLDoc <- case parseXMLDoc $ fromEntry testEntry of
90− Just doc -> Right doc
91− Nothing -> Left $
92− "Can't parse xml in " ++ fp ++ " from generated archive"
93−
94− goldenEntry <- case findEntryByPath fp goldenArch of
95− Just entry -> Right entry
96− Nothing -> Left $
97− "Can't extract " ++ fp ++ " from archive in stored pptx file"
98− goldenXMLDoc <- case parseXMLDoc $ fromEntry goldenEntry of
99− Just doc -> Right doc
100− Nothing -> Left $
101− "Can't parse xml in " ++ fp ++ " from archive in stored pptx file"
102−
103− let testContent = Elem testXMLDoc
104− goldenContent = Elem goldenXMLDoc
105−
106− if compareXMLBool goldenContent testContent
107− then Right ()
108− else Left $
109− "Non-matching xml in " ++ fp ++ ":\n" ++ displayDiff testContent goldenContent
110−
111−compareXMLFile :: FilePath -> Archive -> Archive -> Maybe String
112−compareXMLFile fp goldenArch testArch =
113− case compareXMLFile' fp goldenArch testArch of
114− Right _ -> Nothing
115− Left s -> Just s
116−
117−compareAllXMLFiles :: Archive -> Archive -> Maybe String
118−compareAllXMLFiles goldenArch testArch =
119− let allFiles = filesInArchive goldenArch `union` filesInArchive testArch
120− allXMLFiles = sort $
121− filter
122− (\fp -> ".xml" `isSuffixOf` fp || ".rels" `isSuffixOf` fp)
123− allFiles
124− results =
125− mapMaybe (\fp -> compareXMLFile fp goldenArch testArch) allXMLFiles
126− in
127− if null results
128− then Nothing
129− else Just $ unlines results
130−
131−compareMediaFile' :: FilePath -> Archive -> Archive -> Either String ()
132−compareMediaFile' fp goldenArch testArch = do
133− testEntry <- case findEntryByPath fp testArch of
134− Just entry -> Right entry
135− Nothing -> Left $
136− "Can't extract " ++ fp ++ " from generated archive"
137− goldenEntry <- case findEntryByPath fp goldenArch of
138− Just entry -> Right entry
139− Nothing -> Left $
140− "Can't extract " ++ fp ++ " from archive in stored pptx file"
141−
142− if fromEntry testEntry == fromEntry goldenEntry
143− then Right ()
144− else Left $
145− "Non-matching binary file: " ++ fp
146−
147−compareMediaFile :: FilePath -> Archive -> Archive -> Maybe String
148−compareMediaFile fp goldenArch testArch =
149− case compareMediaFile' fp goldenArch testArch of
150− Right _ -> Nothing
151− Left s -> Just s
152−
153−compareAllMediaFiles :: Archive -> Archive -> Maybe String
154−compareAllMediaFiles goldenArch testArch =
155− let allFiles = filesInArchive goldenArch `union` filesInArchive testArch
156− allMediaFiles = sort $
157− filter
158− (\fp -> "/ppt/media/" `isPrefixOf` fp)
159− allFiles
160− results =
161− mapMaybe (\fp -> compareMediaFile fp goldenArch testArch) allMediaFiles
162− in
163− if null results
164− then Nothing
165− else Just $ unlines results
1666
1677pptxTest :: String -> WriterOptions -> FilePath -> FilePath -> TestTree
168−pptxTest testName opts nativeFP goldenFP =
169− goldenTest
170− testName
171− (goldenArchive goldenFP)
172− (testArchive opts nativeFP)
173− (\goldenArch testArch ->
174− let res = catMaybes [ compareFileList goldenFP goldenArch testArch
175− , compareAllXMLFiles goldenArch testArch
176− , compareAllMediaFiles goldenArch testArch
177− ]
178− in return $ if null res then Nothing else Just $ unlines res)
179− (\a -> BL.writeFile goldenFP $ fromArchive a)
180−
181−--------------------------------------------------------------
8+pptxTest = ooxmlTest writePowerpoint
1829
18310tests :: [TestTree]
18411tests = [ pptxTest