texmath-0.12.9: test/test-texmath.hs

{-# LANGUAGE OverloadedStrings #-}

import System.Directory
import System.FilePath
import Text.XML.Light
import Text.Show.Pretty (ppShow)
import Text.TeXMath
import qualified Data.Text as T
import qualified Data.Text.Lazy as TL
import qualified Data.ByteString.Char8 as B
import Test.Tasty
import Test.Tasty.Golden (goldenVsStringDiff)
import Test.Tasty.Options
import Data.Text.Lazy.Encoding (encodeUtf8)
import Data.Text.Encoding as TE (decodeUtf8)
import Data.List (sort)
import Data.Typeable (Typeable)
import Data.Proxy

newtype RoundTrip = RoundTrip Bool
  deriving (Eq, Ord, Typeable)

instance IsOption RoundTrip where
  defaultValue = RoundTrip False
  parseValue = fmap RoundTrip . safeRead
  optionName = return "roundtrip"
  optionHelp = return "Do round-trip tests instead of regular"
  optionCLParser = flagCLParser Nothing (RoundTrip True)

main :: IO ()
main = do
  let getFiles dir = map (dir </>) . sort <$> listDirectory dir
  texReaderTests <- getFiles "test/reader/tex"
  mmlReaderTests <- getFiles "test/reader/mml"
  ommlReaderTests <- getFiles "test/reader/omml"
  texWriterTests <- getFiles "test/writer/tex"
  mmlWriterTests <- getFiles "test/writer/mml"
  ommlWriterTests <- getFiles "test/writer/omml"
  eqnWriterTests <- getFiles "test/writer/eqn"
  typstWriterTests <- getFiles "test/writer/typst"
  regressionTests <- getFiles "test/regression"
  roundtripTests <- getFiles "test/roundtrip"
  let ings = includingOptions [Option (Proxy :: Proxy RoundTrip)] :
                defaultIngredients
  defaultMainWithIngredients ings $ askOption $ \(RoundTrip roundTrip) ->
    testGroup "Tests" $
      if roundTrip
         then
           [ testGroup "roundtrip"
             [ testGroup "tex" $ map (toRoundtripTest "tex") roundtripTests
             , testGroup "mml" $ map (toRoundtripTest "mml") roundtripTests
             , testGroup "mml" $ map (toRoundtripTest "omml") roundtripTests
             ]
           ]
         else
           [ testGroup "reader"
             [ testGroup "tex" $ map toGoldenTest texReaderTests
             , testGroup "mml" $ map toGoldenTest mmlReaderTests
             , testGroup "omml" $ map toGoldenTest ommlReaderTests
             ],
             testGroup "writer"
             [ testGroup "tex" $ map toGoldenTest texWriterTests
             , testGroup "mml" $ map toGoldenTest mmlWriterTests
             , testGroup "omml" $ map toGoldenTest ommlWriterTests
             , testGroup "eqn" $ map toGoldenTest eqnWriterTests
             , testGroup "typst" $ map toGoldenTest typstWriterTests
             ],
             testGroup "regression" $ map toGoldenTest regressionTests
           ]

toRoundtripTest :: T.Text -> FilePath -> TestTree
toRoundtripTest format fp =
  goldenVsStringDiff (takeBaseName fp) diff fp getTested
 where
  diff ref new = ["diff", "-u", ref, new]

  getTested = do
    golden <- read <$> readFile fp
    reader <- maybe (error $ "Unknown input format " <> T.unpack format)
               return $ lookup format readers
    writer <- maybe (error $ "Unknown output format " <> T.unpack format)
               return $ lookup format writers
    case reader (writer golden) of
      Left err -> return $ encodeUtf8 $ TL.fromStrict err
      Right result -> return $ encodeUtf8 $ TL.fromStrict
                             $ ensureFinalNewline $ T.pack $ ppShow result

toGoldenTest :: FilePath -> TestTree
toGoldenTest fp =
  goldenVsStringDiff (takeBaseName fp) diff fp getTested
 where
  diff ref new = ["diff", "-u", ref, new]

  constructGoldenTest ((inFormat, inText), (outFormat, outText)) =
    return $ encodeUtf8 $ TL.fromStrict $
      "<<< " <> inFormat <> "\n" <> inText <> ">>> " <> outFormat <>
      "\n" <> ensureFinalNewline outText

  getTested = do
    ((inFormat, inText), (outFormat, _)) <- readGoldenTest fp
    result <- convert inFormat outFormat inText
    constructGoldenTest ((inFormat, inText), (outFormat, result))

  convert inFormat outFormat inText = do
    reader <- maybe (error $ "Unknown input format " <> T.unpack inFormat)
               return $ lookup inFormat readers
    writer <- maybe (error $ "Unknown output format " <> T.unpack outFormat)
               return $ lookup outFormat writers
    case writer <$> reader inText of
      Left err -> return err
      Right result -> return result

  readGoldenTest fp' = do
    lns <- B.lines <$> B.readFile fp'
    case break ("<<<" `B.isPrefixOf`) lns of
      (_, inputSpec:rest) ->
        case break (">>>" `B.isPrefixOf`) rest of
          (inlines, outputSpec:outlines) -> return
              ((T.strip $ T.drop 3 $ T.pack $ B.unpack inputSpec,
                 TE.decodeUtf8 $ B.unlines inlines),
               (T.strip $ T.drop 3 $ T.pack $ B.unpack outputSpec,
                 TE.decodeUtf8 $ B.unlines outlines))
          _ -> error $ fp' <> " contains no >>> output spec"
      _ -> error $ fp' <> " contains no <<< input spec"

ensureFinalNewline :: T.Text -> T.Text
ensureFinalNewline xs = case T.unsnoc xs of
  Nothing        -> xs
  Just (_, '\n') -> xs
  _              -> xs <> "\n"


readers :: [(T.Text, T.Text -> Either T.Text [Exp])]
readers = [ ("tex", readTeX)
          , ("mml", readMathML)
          , ("mathml", readMathML)
          , ("omml", readOMML)
          , ("native", readEither)
          ]

readEither :: T.Text -> Either T.Text [Exp]
readEither t = case reads (T.unpack t) of
                  [] -> error "Could not read native value"
                  ((x,_):_) -> return x

writers :: [(T.Text, [Exp] -> T.Text)]
writers = [ ("mml", T.pack . ppTopElement . writeMathML DisplayBlock)
          , ("tex", writeTeX)
          , ("omml", T.pack . ppTopElement . writeOMML DisplayBlock)
          , ("eqn", writeEqn DisplayBlock)
          , ("typst", writeTypst DisplayBlock)
          , ("native", T.pack . ppShow)
          , ("pandoc", maybe "" (T.pack . ppShow) . writePandoc DisplayBlock)
          ]