git.iko.soy/typeable/pandoc
on rc/test4 help sign in
typeable/pandoc/test/Tests/Helpers.hs
162 lines 5.2 kB history raw
1{-# LANGUAGE CPP #-}
2{-# LANGUAGE NoImplicitPrelude #-}
3{-# LANGUAGE FlexibleInstances #-}
4{- |
5 Module : Tests.Helpers
6 Copyright : © 2006-2020 John MacFarlane
7 License : GNU GPL, version 2 or above
9 Maintainer : John MacFarlane <jgm@berkeley@edu>
10 Stability : alpha
11 Portability : portable
13Utility functions for the test suite.
14-}
15module Tests.Helpers ( test
16 , TestResult(..)
17 , showDiff
18 , findPandoc
19 , (=?>)
20 , purely
21 , ToString(..)
22 , ToPandoc(..)
23 )
24 where
26import Prelude
27import Data.Algorithm.Diff
28import qualified Data.Map as M
29import Data.Text (Text, unpack)
30import System.Directory
31import System.Environment.Executable (getExecutablePath)
32import System.Exit
33import System.FilePath
34import Test.Tasty
35import Test.Tasty.HUnit
36import Text.Pandoc.Builder (Blocks, Inlines, doc, plain)
37import Text.Pandoc.Class
38import Text.Pandoc.Definition
39import Text.Pandoc.Options
40import Text.Pandoc.Shared (trimr)
41import Text.Pandoc.Writers.Native (writeNative)
42import Text.Printf
44test :: (ToString a, ToString b, ToString c)
45 => (a -> b) -- ^ function to test
46 -> String -- ^ name of test case
47 -> (a, c) -- ^ (input, expected value)
48 -> TestTree
49test fn name (input, expected) =
50 testCase name' $ assertBool msg (actual' == expected')
51 where msg = nl ++ dashes "input" ++ nl ++ input' ++ nl ++
52 dashes "result" ++ nl ++
53 unlines (map vividize diff) ++
54 dashes ""
55 nl = "\n"
56 name' = if length name > 54
57 then take 52 name ++ "..." -- avoid wide output
58 else name
59 input' = toString input
60 actual' = lines $ toString $ fn input
61 expected' = lines $ toString expected
62 diff = getDiff expected' actual'
63 dashes "" = replicate 72 '-'
64 dashes x = replicate (72 - length x - 5) '-' ++ " " ++ x ++ " ---"
66data TestResult = TestPassed
67 | TestError ExitCode
68 | TestFailed String FilePath [Diff String]
69 deriving (Eq)
71instance Show TestResult where
72 show TestPassed = "PASSED"
73 show (TestError ec) = "ERROR " ++ show ec
74 show (TestFailed cmd file d) = '\n' : dash ++
75 "\n--- " ++ file ++
76 "\n+++ " ++ cmd ++ "\n" ++ showDiff (1,1) d ++
77 dash
78 where dash = replicate 72 '-'
80showDiff :: (Int,Int) -> [Diff String] -> String
81showDiff _ [] = ""
82showDiff (l,r) (First ln : ds) =
83 printf "+%4d " l ++ ln ++ "\n" ++ showDiff (l+1,r) ds
84showDiff (l,r) (Second ln : ds) =
85 printf "-%4d " r ++ ln ++ "\n" ++ showDiff (l,r+1) ds
86showDiff (l,r) (Both _ _ : ds) =
87 showDiff (l+1,r+1) ds
89-- | Find pandoc executable relative to test-pandoc
90findPandoc :: IO FilePath
91findPandoc = do
92 testExePath <- getExecutablePath
93 let pandocDir =
94 case reverse (splitDirectories (takeDirectory testExePath)) of
95 -- cabalv2 with --disable-optimization
96 "test-pandoc" : "build" : "noopt" : "test-pandoc" : "t" : ps
97 -> joinPath (reverse ps) </>
98 "x" </> "pandoc" </> "noopt" </> "build" </> "pandoc"
99 -- cabalv2 without --disable-optimization
100 "test-pandoc" : "build" : "test-pandoc" : "t" : ps
101 -> joinPath (reverse ps) </>
102 "x" </> "pandoc" </> "build" </> "pandoc"
103 -- cabalv1
104 "test-pandoc" : "build" : ps
105 -> joinPath (reverse ps) </> "build" </> "pandoc"
106 _ -> error "findPandoc: could not find pandoc executable"
107 let pandocPath = pandocDir </> "pandoc"
108#ifdef _WINDOWS
109 <.> "exe"
110#endif
111 found <- doesFileExist pandocPath
112 if found
113 then return pandocPath
114 else error $ "findPandoc: could not find pandoc executable at "
115 ++ pandocPath
117vividize :: Diff String -> String
118vividize (Both s _) = " " ++ s
119vividize (First s) = "- " ++ s
120vividize (Second s) = "+ " ++ s
122purely :: (b -> PandocPure a) -> b -> a
123purely f = either (error . show) id . runPure . f
125infix 5 =?>
126(=?>) :: a -> b -> (a,b)
127x =?> y = (x, y)
129class ToString a where
130 toString :: a -> String
132instance ToString Pandoc where
133 toString d = unpack $
134 purely (writeNative def{ writerTemplate = s }) $ toPandoc d
135 where s = case d of
136 (Pandoc (Meta m) _)
137 | M.null m -> Nothing
138 | otherwise -> Just mempty -- need this to get meta output
140instance ToString Blocks where
141 toString = unpack . purely (writeNative def) . toPandoc
143instance ToString Inlines where
144 toString = unpack . trimr . purely (writeNative def) . toPandoc
146instance ToString String where
147 toString = id
149instance ToString Text where
150 toString = unpack
152class ToPandoc a where
153 toPandoc :: a -> Pandoc
155instance ToPandoc Pandoc where
156 toPandoc = id
158instance ToPandoc Blocks where
159 toPandoc = doc
161instance ToPandoc Inlines where
162 toPandoc = doc . plain