typst-0.12.1: test/Main.hs

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE OverloadedLists #-}

module Main (main) where

import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as BL
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
import System.FilePath (replaceExtension)
import System.Info (os)
import Test.Tasty (TestTree, Timeout (..), defaultMain, localOption, testGroup)
import Test.Tasty.Golden (findByExtension, goldenVsStringDiff)
import Text.Show.Pretty (ppShow)
import Typst.Evaluate (evaluateTypst)
import Typst.Parse (parseTypst)
import Typst.Syntax (Markup)
import Typst.Types (Val (VContent), repr, Operations(..))
import Data.Time (getCurrentTime)
import System.Directory (doesFileExist, setCurrentDirectory)
import System.Environment (lookupEnv)

main :: IO ()
main = defaultMain =<< goldenTests

operations :: Operations IO
operations = Operations
  { loadBytes = BS.readFile
  , currentUTCTime = getCurrentTime
  , lookupEnvVar = lookupEnv
  , checkExistence = doesFileExist
  }

goldenTests :: IO TestTree
goldenTests = do
  let testCommand =
        "#let test = (x,y) => { if x == y [✅] else [❌(#repr(x) /= #repr(y))] }"
  let testParse = either (error . show) id $ parseTypst "test-command" testCommand
  
  setCurrentDirectory "test"
  inputs <- findByExtension [".typ"] "typ"
  pure $
    localOption (Timeout 1000000 "1s") $
      testGroup "golden tests" (map (runTest testParse . map fixSeparator) inputs)
  where
    -- Golden files record paths with forward slashes.
    fixSeparator '\\' = '/'
    fixSeparator c = c

runTest :: [Markup] -> FilePath -> TestTree
runTest testParse input =
  goldenVsStringDiff
    input
    (\ref new -> ["diff", "-u", ref, new])
    (replaceExtension input ".out")
    (writeTest testParse input)

writeTest :: [Markup] -> FilePath -> IO BL.ByteString
writeTest testParse input = do
  let fromText = BL.fromStrict . TE.encodeUtf8 . nativeNewlines . (<> "\n")
  contents <- TE.decodeUtf8 <$> BS.readFile input
  if "// Error"
    `T.isInfixOf` contents
    || "cycle1.typ"
    `T.isInfixOf` contents
    || "cycle2.typ"
    `T.isInfixOf` contents
    then pure $ fromText "--- skipped ---\n"
    else do
      let parseResult = parseTypst input contents
      case parseResult of
        Left e -> pure $ fromText $ T.pack $ show e
        Right parsed -> do
          evalResult <- evaluateTypst operations [] input (testParse <> parsed)
          let parseOutput = "--- parse tree ---\n" <> T.pack (ppShow parsed) <> "\n"
          case evalResult of
            Left e ->
              pure $
                fromText $
                  parseOutput <> T.pack (show e)
            Right c -> do
              let evalOutput = "--- evaluated ---\n" <> repr (VContent [c])
              pure $ fromText $ parseOutput <> evalOutput

-- Git converts golden files to CRLF when checking them out on Windows.
nativeNewlines :: T.Text -> T.Text
nativeNewlines
  | os == "mingw32" = T.replace "\n" "\r\n"
  | otherwise = id