pandoc/test/Tests/Helpers.hs

{-# LANGUAGE CPP #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE FlexibleInstances    #-}
{- |
   Module      : Tests.Helpers
   Copyright   : © 2006-2022 John MacFarlane
   License     : GNU GPL, version 2 or above

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

Utility functions for the test suite.
-}
module Tests.Helpers ( test
                     , TestResult(..)
                     , setupEnvironment
                     , showDiff
                     , testGolden
                     , (=?>)
                     , purely
                     , ToString(..)
                     , ToPandoc(..)
                     )
                     where

import System.FilePath
import Data.Algorithm.Diff
import qualified Data.Map as M
import qualified Text.Pandoc.UTF8 as UTF8
import Data.Text (Text, unpack)
import qualified Data.Text as T
import System.Exit
import qualified System.Environment as Env
import Test.Tasty
import Test.Tasty.Golden.Advanced (goldenTest)
import Test.Tasty.HUnit
import Text.Pandoc.Builder (Blocks, Inlines, doc, plain)
import Text.Pandoc.Class
import Text.Pandoc.Definition
import Text.Pandoc.Options
import Text.Pandoc.Shared (trimr)
import Text.Pandoc.Writers.Native (writeNative)
import Text.Printf

test :: (ToString a, ToString b, ToString c, HasCallStack)
     => (a -> b)  -- ^ function to test
     -> String    -- ^ name of test case
     -> (a, c)    -- ^ (input, expected value)
     -> TestTree
test fn name (input, expected) =
  testCase name' $ assertBool msg (actual' == expected')
     where msg = nl ++ dashes "input" ++ nl ++ input' ++ nl ++
                 dashes "result" ++ nl ++
                 unlines (map vividize diff) ++
                 dashes ""
           nl = "\n"
           name'   = if length name > 54
                        then take 52 name ++ "..."  -- avoid wide output
                        else name
           input'  = toString input
           actual' = lines $ toString $ fn input
           expected' = lines $ toString expected
           diff = getDiff expected' actual'
           dashes "" = replicate 72 '-'
           dashes x  = replicate (72 - length x - 5) '-' ++ " " ++ x ++ " ---"

testGolden :: TestName -> FilePath -> FilePath -> (Text -> IO Text) -> TestTree
testGolden  name expectedPath inputPath fn =
  goldenTest
    name
    (UTF8.readFile expectedPath)
    (UTF8.readFile inputPath >>= fn)
    compareVals
    (UTF8.writeFile expectedPath)
 where
  compareVals expected actual
    | expected == actual = return Nothing
    | otherwise =  return $ Just $
        "\n--- " ++ expectedPath ++ "\n+++\n" ++
        showDiff (1,1)
          (getDiff (lines . filter (/='\r') $ T.unpack actual)
                   (lines . filter (/='\r') $ T.unpack expected))

-- | Set up environment for pandoc command tests.
setupEnvironment :: FilePath -> IO [(String, String)]
setupEnvironment testExePath = do
  mldpath   <- Env.lookupEnv "LD_LIBRARY_PATH"
  mdyldpath <- Env.lookupEnv "DYLD_LIBRARY_PATH"
  mpdd <- Env.lookupEnv "pandoc_datadir"
  -- Note that Cabal sets the pandoc_datadir environment variable
  -- to point to the source directory, since otherwise getDataFilename
  -- will look in the data directory into which pandoc will be installed
  -- (but has not yet been).  So when we spawn a new process with
  -- pandoc, we need to make sure this environment variable is set.
  return $ ("PATH",takeDirectory testExePath) :
           ("TMP",".") :
           ("LANG","en_US.UTF-8") :
           ("HOME", "./") :
           maybe [] ((:[]) . ("pandoc_datadir",)) mpdd ++
           maybe [] ((:[]) . ("LD_LIBRARY_PATH",)) mldpath ++
           maybe [] ((:[]) . ("DYLD_LIBRARY_PATH",)) mdyldpath

data TestResult = TestPassed
                | TestError ExitCode
                | TestFailed String FilePath [Diff String]
     deriving (Eq)

instance Show TestResult where
  show TestPassed     = "PASSED"
  show (TestError ec) = "ERROR " ++ show ec
  show (TestFailed cmd file d) = '\n' : dash ++
                                 "\n--- " ++ file ++
                                 "\n+++ " ++ cmd ++ "\n" ++ showDiff (1,1) d ++
                                 dash
    where dash = replicate 72 '-'

showDiff :: (Int,Int) -> [Diff String] -> String
showDiff _ []             = ""
showDiff (l,r) (First ln : ds) =
  printf "+%4d " l ++ ln ++ "\n" ++ showDiff (l+1,r) ds
showDiff (l,r) (Second ln : ds) =
  printf "-%4d " r ++ ln ++ "\n" ++ showDiff (l,r+1) ds
showDiff (l,r) (Both _ _ : ds) =
  showDiff (l+1,r+1) ds

vividize :: Diff String -> String
vividize (Both s _) = "  " ++ s
vividize (First s)  = "- " ++ s
vividize (Second s) = "+ " ++ s

purely :: (b -> PandocPure a) -> b -> a
purely f = either (error . show) id . runPure . f

infix 5 =?>
(=?>) :: a -> b -> (a,b)
x =?> y = (x, y)

class ToString a where
  toString :: a -> String

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

instance ToString Blocks where
  toString = unpack . purely (writeNative def) . toPandoc

instance ToString Inlines where
  toString = unpack . trimr . purely (writeNative def) . toPandoc

instance ToString String where
  toString = id

instance ToString Text where
  toString = unpack

class ToPandoc a where
  toPandoc :: a -> Pandoc

instance ToPandoc Pandoc where
  toPandoc = id

instance ToPandoc Blocks where
  toPandoc = doc

instance ToPandoc Inlines where
  toPandoc = doc . plain