pandoc/test/Tests/Readers/ODT.hs

{-# LANGUAGE OverloadedStrings #-}
{- |
   Module      : Tests.Readers.ODT
   Copyright   : © 2015-2023 John MacFarlane
                   2015 Martin Linnemann
   License     : GNU GPL, version 2 or above

   Maintainer  : John MacFarlane <jgm@berkeley.edu>
   Stability   : alpha
   Portability : portable

Tests for the ODT reader.
-}
module Tests.Readers.ODT (tests) where

import Control.Monad (liftM)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as B
import qualified Data.Map as M
import Data.Text (unpack)
import System.IO.Unsafe (unsafePerformIO)
import Test.Tasty
import Tests.Helpers
import Text.Pandoc
import qualified Text.Pandoc.UTF8 as UTF8

defopts :: ReaderOptions
defopts = def{ readerExtensions = getDefaultExtensions "odt" }

tests :: [TestTree]
tests = testsComparingToMarkdown ++ testsComparingToNative

testsComparingToMarkdown :: [TestTree]
testsComparingToMarkdown    = map nameToTest namesOfTestsComparingToMarkdown
  where nameToTest     name = createTest
                                compareODTToMarkdown
                                name
                                (toODTPath      name)
                                (toMarkdownPath name)
        toODTPath      name = "odt/odt/"      ++ name ++ ".odt"
        toMarkdownPath name = "odt/markdown/" ++ name ++ ".md"

testsComparingToNative   :: [TestTree]
testsComparingToNative      = map nameToTest namesOfTestsComparingToNative
  where nameToTest     name = createTest
                                compareODTToNative
                                name
                                (toODTPath      name)
                                (toNativePath   name)
        toODTPath      name = "odt/odt/"      ++ name ++ ".odt"
        toNativePath   name = "odt/native/"   ++ name ++ ".native"


newtype NoNormPandoc = NoNormPandoc {unNoNorm :: Pandoc}
  deriving ( Show )

instance ToString NoNormPandoc where
  toString d = unpack $
               purely (writeNative def{ writerTemplate = s }) $ toPandoc d
   where s = case d of
                  NoNormPandoc (Pandoc (Meta m) _)
                    | M.null m  -> Nothing
                    | otherwise -> Just mempty -- need this for Meta output

instance ToPandoc NoNormPandoc where
  toPandoc = unNoNorm

getNoNormVia :: (a -> Pandoc) -> String -> Either PandocError a -> NoNormPandoc
getNoNormVia _ readerName (Left  _) = error (readerName ++ " reader failed")
getNoNormVia f _          (Right a) = NoNormPandoc (f a)

type TestCreator =  ReaderOptions
                 -> FilePath -> FilePath
                 -> IO (NoNormPandoc, NoNormPandoc)

compareODTToNative   :: TestCreator
compareODTToNative opts odtPath nativePath = do
   nativeFile   <- UTF8.toText <$> BS.readFile nativePath
   odtFile      <- B.readFile       odtPath
   native       <- getNoNormVia id  "native" <$> runIO (readNative def nativeFile)
   odt          <- getNoNormVia id  "odt"    <$> runIO (readODT  opts odtFile)
   return (odt,native)

compareODTToMarkdown :: TestCreator
compareODTToMarkdown opts odtPath markdownPath = do
   markdownFile <- UTF8.toText <$> BS.readFile markdownPath
   odtFile      <- B.readFile       odtPath
   markdown     <- getNoNormVia id "markdown" <$>
                      runIO (readMarkdown def{ readerExtensions = pandocExtensions }
                              markdownFile)
   odt          <- getNoNormVia id "odt"      <$> runIO (readODT      opts odtFile)
   return (odt,markdown)


createTest :: TestCreator
           -> TestName
           -> FilePath -> FilePath
           -> TestTree
createTest   creator name path1 path2 =
  unsafePerformIO $ liftM (test id name) (creator defopts path1 path2)

{-
--

getMedia :: FilePath -> FilePath -> IO (Maybe B.ByteString)
getMedia archivePath mediaPath = do
  zf <- B.readFile archivePath >>= return . toArchive
  return $ findEntryByPath ("Pictures/" ++ mediaPath) zf >>= (Just . fromEntry)

compareMediaPathIO :: FilePath -> MediaBag -> FilePath -> IO Bool
compareMediaPathIO mediaPath mediaBag odtPath = do
  odtMedia <- getMedia odtPath mediaPath
  let mbBS   = case lookupMedia mediaPath mediaBag of
                 Just (_, bs) -> bs
                 Nothing      -> error ("couldn't find " ++
                                        mediaPath ++
                                        " in media bag")
      odtBS = case odtMedia of
                 Just bs -> bs
                 Nothing -> error ("couldn't find " ++
                                   mediaPath ++
                                   " in media bag")
  return $ mbBS == odtBS

compareMediaBagIO :: FilePath -> IO Bool
compareMediaBagIO odtFile = do
    df <- B.readFile odtFile
    let (_, mb) = readODT def df
    bools <- mapM
             (\(fp, _, _) -> compareMediaPathIO fp mb odtFile)
             (mediaDirectory mb)
    return $ and bools

testMediaBagIO :: String -> FilePath -> IO TestTree
testMediaBagIO name odtFile = do
  outcome <- compareMediaBagIO odtFile
  return $ testCase name (assertBool
                          ("Media didn't match media bag in file " ++ odtFile)
                          outcome)

testMediaBag :: String -> FilePath -> TestTree
testMediaBag name odtFile = buildTest $ testMediaBagIO name odtFile
-}
--



namesOfTestsComparingToMarkdown :: [ String ]
namesOfTestsComparingToMarkdown  = [ "blockquote2"
                                   , "bold"
--                                 , "citation"
                                   , "endnote"
                                   , "externalLink"
                                   , "footnote"
                                   , "formula"
                                   , "headers"
--                                 , "horizontalRule"
                                   , "italic"
--                                 , "listBlocks"
                                   , "paragraph"
                                   , "strikeout"
--                                 , "trackedChanges"
                                   , "underlined"
                                   ]

namesOfTestsComparingToNative  :: [ String ]
namesOfTestsComparingToNative   = [ "blockquote"
                                  , "image"
                                  , "imageIndex"
                                  , "imageWithCaption"
                                  , "inlinedCode"
                                  , "orderedListMixed"
                                  , "orderedListRoman"
                                  , "orderedListSimple"
                                  , "orderedListHeader"
                                  , "referenceToChapter"
                                  , "referenceToListItem"
                                  , "referenceToText"
                                  , "simpleTable"
                                  , "simpleTableWithCaption"
                                  , "tab"
--                                , "table"
                                  , "textMixedStyles"
                                  , "tableWithContents"
                                  , "unicode"
                                  , "unorderedList"
                                  , "unorderedListHeader"
                                  ]