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