git.iko.soy/typeable/pandoc
on 2aa0832 help sign in
typeable/pandoc/test/Tests/Command.hs
109 lines 4.3 kB history raw
1{-# LANGUAGE NoImplicitPrelude #-}
2{- |
3 Module : Tests.Command
4 Copyright : © 2006-2020 John MacFarlane
5 License : GNU GPL, version 2 or above
7 Maintainer : John MacFarlane <jgm@berkeley@edu>
8 Stability : alpha
9 Portability : portable
11Run commands, and test results, defined in markdown files.
12-}
13module Tests.Command (findPandoc, runTest, tests)
14where
16import Prelude
17import Data.Algorithm.Diff
18import qualified Data.ByteString as BS
19import qualified Data.Text as T
20import Data.List (isSuffixOf, intercalate)
21import Data.Maybe (catMaybes)
22import System.Directory
23import qualified System.Environment as Env
24import System.Exit
25import System.FilePath (joinPath, splitDirectories, takeDirectory, (</>))
26import System.IO (hPutStr, stderr)
27import System.IO.Unsafe (unsafePerformIO)
28import System.Process
29import Test.Tasty
30import Test.Tasty.HUnit
31import Tests.Helpers
32import Text.Pandoc
33import qualified Text.Pandoc.UTF8 as UTF8
35-- | Run a test with normalize function, return True if test passed.
36runTest :: String -- ^ Title of test
37 -> FilePath -- ^ Path to pandoc
38 -> String -- ^ Shell command
39 -> String -- ^ Input text
40 -> String -- ^ Expected output
41 -> TestTree
42runTest testname pandocpath cmd inp norm = testCase testname $ do
43 mldpath <- Env.lookupEnv "LD_LIBRARY_PATH"
44 mdyldpath <- Env.lookupEnv "DYLD_LIBRARY_PATH"
45 let findDynlibDir [] = Nothing
46 findDynlibDir ("build":xs) = Just $ joinPath (reverse xs) </> "build"
47 findDynlibDir (_:xs) = findDynlibDir xs
48 let mbDynlibDir = findDynlibDir (reverse $ splitDirectories $
49 takeDirectory $ takeWhile (/=' ') cmd)
50 let dynlibEnv = [("DYLD_LIBRARY_PATH", intercalate ":" $ catMaybes [mbDynlibDir, mdyldpath])
51 ,("LD_LIBRARY_PATH", intercalate ":" $ catMaybes [mbDynlibDir, mldpath])]
52 let env' = dynlibEnv ++ [("PATH",takeDirectory pandocpath),("TMP","."),("LANG","en_US.UTF-8"),("HOME", "./"),("pandoc_datadir", "..")]
53 let pr = (shell cmd){ env = Just env' }
54 (ec, out', err') <- readCreateProcessWithExitCode pr inp
55 -- filter \r so the tests will work on Windows machines
56 let out = filter (/= '\r') $ err' ++ out'
57 result <- if ec == ExitSuccess
58 then
59 if out == norm
60 then return TestPassed
61 else return
62 $ TestFailed cmd "expected"
63 $ getDiff (lines out) (lines norm)
64 else do
65 hPutStr stderr err'
66 return $ TestError ec
67 assertBool (show result) (result == TestPassed)
69tests :: FilePath -> TestTree
70{-# NOINLINE tests #-}
71tests pandocPath = unsafePerformIO $ do
72 files <- filter (".md" `isSuffixOf`) <$>
73 getDirectoryContents "command"
74 let cmds = map (extractCommandTest pandocPath) files
75 return $ testGroup "Command:" cmds
77isCodeBlock :: Block -> Bool
78isCodeBlock (CodeBlock _ _) = True
79isCodeBlock _ = False
81extractCode :: Block -> String
82extractCode (CodeBlock _ code) = T.unpack code
83extractCode _ = ""
85dropPercent :: String -> String
86dropPercent ('%':xs) = dropWhile (== ' ') xs
87dropPercent xs = xs
89runCommandTest :: FilePath -> Int -> String -> TestTree
90runCommandTest pandocpath num code =
91 let codelines = lines code
92 (continuations, r1) = span ("\\" `isSuffixOf`) codelines
93 (cmd, r2) = (dropPercent (unwords (map init continuations ++ take 1 r1)),
94 drop 1 r1)
95 (inplines, r3) = break (=="^D") r2
96 normlines = takeWhile (/=".") (drop 1 r3)
97 input = unlines inplines
98 norm = unlines normlines
99 shcmd = cmd -- trimr $ takeDirectory pandocpath </> cmd
100 in runTest ("#" ++ show num) pandocpath shcmd input norm
102extractCommandTest :: FilePath -> FilePath -> TestTree
103extractCommandTest pandocpath fp = unsafePerformIO $ do
104 contents <- UTF8.toText <$> BS.readFile ("command" </> fp)
105 Pandoc _ blocks <- runIOorExplode (readMarkdown
106 def{ readerExtensions = pandocExtensions } contents)
107 let codeblocks = map extractCode $ filter isCodeBlock blocks
108 let cases = zipWith (runCommandTest pandocpath) [1..] codeblocks
109 return $ testGroup fp cases