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
152
153
154
155
156
157
158
159
160
161
162
163
|
{-# LANGUAGE CPP #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeSynonymInstances #-}
{- |
Module : Tests.Helpers
Copyright : © 2006-2020 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(..)
, showDiff
, findPandoc
, (=?>)
, purely
, ToString(..)
, ToPandoc(..)
)
where
import Prelude
import Data.Algorithm.Diff
import qualified Data.Map as M
import Data.Text (Text, unpack)
import System.Directory
import System.Environment.Executable (getExecutablePath)
import System.Exit
import System.FilePath
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)
=> (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 ++ " ---"
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
-- | Find pandoc executable relative to test-pandoc
findPandoc :: IO FilePath
findPandoc = do
testExePath <- getExecutablePath
let pandocDir =
case reverse (splitDirectories (takeDirectory testExePath)) of
-- cabalv2 with --disable-optimization
"test-pandoc" : "build" : "noopt" : "test-pandoc" : "t" : ps
-> joinPath (reverse ps) </>
"x" </> "pandoc" </> "noopt" </> "build" </> "pandoc"
-- cabalv2 without --disable-optimization
"test-pandoc" : "build" : "test-pandoc" : "t" : ps
-> joinPath (reverse ps) </>
"x" </> "pandoc" </> "build" </> "pandoc"
-- cabalv1
"test-pandoc" : "build" : ps
-> joinPath (reverse ps) </> "build" </> "pandoc"
_ -> error $ "findPandoc: could not find pandoc executable"
let pandocPath = pandocDir </> "pandoc"
#ifdef _WINDOWS
<.> "exe"
#endif
found <- doesFileExist pandocPath
if found
then return pandocPath
else error $ "findPandoc: could not find pandoc executable at "
++ pandocPath
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
|
