1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
|
{-# LANGUAGE CPP #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE FlexibleInstances #-}
{- |
Module : Tests.Helpers
Copyright : © 2006-2021 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
, (=?>)
, purely
, ToString(..)
, ToPandoc(..)
)
where
import Data.Algorithm.Diff
import qualified Data.Map as M
import Data.Text (Text, unpack)
import System.Exit
import System.FilePath (takeDirectory)
import qualified System.Environment as Env
import Test.Tasty
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 ++ " ---"
-- | 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
|
