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