]> git.wincent.com - docvim.git/blob - tests/Tasty.hs
Tweak function and command output in Vim help printer to stand out more
[docvim.git] / tests / Tasty.hs
1 {-# LANGUAGE CPP #-}
2 {-# OPTIONS_GHC -fno-warn-type-defaults #-}
3
4 module Main (main) where
5
6 #if !MIN_VERSION_base(4,8,0)
7 import Control.Applicative ((<$>))
8 #endif
9 import Control.DeepSeq
10 import Control.Exception hiding (assert)
11 import Data.ByteString.Lazy.UTF8 (fromString, toString)
12 import Data.Char
13 import Data.List --(isPrefixOf, sort)
14 import Data.Monoid
15 import System.Directory
16 import System.Exit
17 import System.FilePath
18 import System.IO
19 import System.IO.Temp
20 import System.Process
21 import Test.Tasty
22 import Test.Tasty.Golden
23 import Test.Tasty.Golden.Advanced
24 import Test.Tasty.HUnit
25 import Text.Docvim.AST
26 import Text.Docvim.Util
27 import Text.Docvim.Visitor.Symbol
28 import qualified Data.ByteString as ByteString
29 import qualified Data.ByteString.Lazy as LazyByteString
30
31 -- | Crude check to see if parse worked.
32 parseSuccess :: Either a b -> Bool
33 parseSuccess (Left _) = False
34 parseSuccess _        = True
35
36 unitTests :: TestTree
37 unitTests = testGroup "Unit tests"
38   [ testCase "Compile empty unit" $ assert $ parseSuccess (compileUnits [""])
39   , testCase "Compile whitespace-only unit" $ assert $ parseSuccess (compileUnits ["  \n    "])
40
41   , testCase "Counting all nodes" $
42     7 @=? let
43         tree = Unit
44           [ FunctionDeclaration True
45                               "name"
46                               (ArgumentList [])
47                               []
48                               [UnletStatement True "foo"]
49           , DocBlock [ HeadingAnnotation "foo"
50                     , SubheadingAnnotation "bar"
51                     , SubheadingAnnotation "baz"
52                     ]
53           ]
54         counter _ = 1
55         nodeCount = getSum $ walk counter (Sum 0) tree
56       in nodeCount
57
58   , testCase "Gathering specific nodes" $
59     [SubheadingAnnotation "bar", SubheadingAnnotation "baz"] @=? let
60         tree = DocBlock [ HeadingAnnotation "foo"
61                         , SubheadingAnnotation "bar"
62                         , SubheadingAnnotation "baz"
63                         ]
64         accumulateSubheadings node@(SubheadingAnnotation _) = [node]
65         accumulateSubheadings _ = [] -- skip everything else
66         selection = walk accumulateSubheadings [] tree
67       in selection
68
69   , testCase "Extracting symbols" $
70     sort ["foo", "bar", "baz"] @=? let
71         tree = DocBlock [ LinkTargets ["foo"]
72                         , LinkTargets ["bar", "baz"]
73                         ]
74         symbols = sort $ getSymbols tree
75       in symbols
76
77   , testCase "Synthesizing symbols from the @plugin annotation" $
78     sort ["foo", "foo.txt", "bar"] @=? let
79         tree = DocBlock [ PluginAnnotation "foo" "some plugin"
80                         , LinkTargets ["bar"]
81                         ]
82         symbols = sort $ getSymbols tree
83       in symbols
84
85   , testCase "Synthesizing symbols from the headings" $
86     -- will need to pass in plugin name (prefix) to make this work
87     sort ["foo", "foo.txt", "foo-history", "foo-troubleshooting-tips", "bar"] @=? let
88         tree = DocBlock [ PluginAnnotation "foo" "some plugin"
89                         , HeadingAnnotation "History"
90                         , HeadingAnnotation "Troubleshooting tips"
91                         , LinkTargets ["bar"]
92                         ]
93         symbols = sort $ getSymbols tree
94       in symbols
95   ]
96
97 diff :: String -> String -> [String]
98 diff ref new = [ "git"
99               , "diff"
100               , "--color"
101               , "--diff-algorithm=histogram"
102               , ref
103               , new
104               ]
105
106 goldenTests :: String -> [FilePath] -> ([String] -> String) -> TestTree
107 goldenTests description sources transform = testGroup groupName $ do
108     file <- sources -- list monad
109     let
110       run = do
111         input <- readFile file
112         let output = normalize $ transform [input]
113         return $ fromString output
114       name = takeBaseName file
115       golden = replaceExtension file ".golden"
116     return $ goldenVsStringDiff' name diff golden run
117   where
118     groupName = "Golden " ++ description ++ " tests"
119
120 integrationTests :: [FilePath] -> TestTree
121 integrationTests sources = testGroup "Integration tests" $
122     concat [ run "ast" (p)
123            , run "markdown" (pm)
124            , run "plaintext" (pv)
125            ]
126   where
127     run kind process = do
128       source <- sources -- list monad
129       let
130         output = do
131           inputs <- getFixtures $ source </> "input"
132           contents <- mapM readFile (sort inputs)
133           return $ fromString $ normalize $ process contents
134         name = takeBaseName source
135         golden = "tests/fixtures/integration" </> (takeBaseName source) </> "golden/" ++ kind ++ ".golden"
136       return $ goldenVsStringDiff' (name ++ " (" ++ kind ++ ")") diff golden output
137
138 -- | Normalize a string to always end with a newline, unless zero-length, to
139 -- match standard text editor behavior.
140 normalize :: String -> String
141 normalize s | s == ""   = ""
142             | otherwise = if last s == '\n' then s else s ++ "\n"
143
144 -- | This is based on `goldenVsStringDiff` function defined in:
145 -- https://github.com/feuerbach/tasty-golden/blob/470e7af018/Test/Tasty/Golden.hs#L150-L191
146 --
147 -- Differences:
148 --
149 --  - Omission of the verbose/ugly failure output message (this is the
150 --    motivating change here).
151 --  - Strip diff headers up to first "@@" (again, for brevity).
152 --  - Some revised names to make things a little clearer.
153 --  - Removed an `error` call which I am not worried about needing.
154 --
155 goldenVsStringDiff' :: TestName -> (FilePath -> FilePath -> [String]) -> FilePath -> IO LazyByteString.ByteString -> TestTree
156 goldenVsStringDiff' name diff' golden run =
157   goldenTest
158     name
159     (ByteString.readFile golden)
160     (LazyByteString.toStrict <$> run)
161     cmp
162     update
163   where
164     template = takeFileName golden <.> "actual"
165     hunkHeader = map chr [0x1b, 0x5b, 0x33, 0x36, 0x6d] ++ "@@ "
166     strip out = unlines $ dropWhile (not . isPrefixOf hunkHeader) (lines $ toString out)
167     cmp _ actBS = withSystemTempFile template $ \tmpFile tmpHandle -> do
168       ByteString.hPut tmpHandle actBS >> hFlush tmpHandle
169       let cmd = diff' golden tmpFile
170       (_, Just sout, _, pid) <- createProcess (proc (head cmd) (tail cmd)) { std_out = CreatePipe }
171       out <- LazyByteString.hGetContents sout
172       evaluate . rnf $ out
173       r <- waitForProcess pid
174       return $ case r of
175         ExitSuccess -> Nothing
176         _ -> Just (strip out)
177     update = ByteString.writeFile golden
178
179 getFixtures :: FilePath -> IO [FilePath]
180 getFixtures = findByExtension [".vim"]
181
182 getIntegrationFixtures :: FilePath -> IO [FilePath]
183 getIntegrationFixtures path = do
184   names <- getDirectoryContents path
185   let filtered = filter (\name -> not $ "." `isPrefixOf` name) names
186   return $ map (\name -> path </> name) filtered
187
188 main :: IO ()
189 main = do
190   parserSources <- getFixtures "tests/fixtures/parser"
191   markdownSources <- getFixtures "tests/fixtures/markdown"
192   vimHelpSources <- getFixtures "tests/fixtures/vim"
193   integrationSources <- getIntegrationFixtures "tests/fixtures/integration"
194   defaultMain $ testGroup "Test suite"
195     [ unitTests
196     , goldenTests "parser" (sort parserSources) p
197     , goldenTests "Markdown printer" (sort markdownSources) pm
198     , goldenTests "Vim help printer" (sort vimHelpSources) pv
199     , integrationTests integrationSources
200     ]