|
1 | | -{-# LANGUAGE CPP #-} |
2 | | -{-# LANGUAGE DataKinds #-} |
3 | 1 | {-# LANGUAGE DuplicateRecordFields #-} |
| 2 | +{-# LANGUAGE NamedFieldPuns #-} |
4 | 3 | {-# LANGUAGE OverloadedStrings #-} |
5 | | -{-# LANGUAGE ScopedTypeVariables #-} |
6 | 4 | {-# LANGUAGE TypeOperators #-} |
7 | 5 | {-# LANGUAGE ViewPatterns #-} |
8 | 6 |
|
9 | | -module Main (main) where |
| 7 | +module Main |
| 8 | + ( main |
| 9 | + ) where |
10 | 10 |
|
11 | | -import Control.Monad |
| 11 | +import Control.Monad (void) |
12 | 12 | import Data.List (find) |
13 | 13 | import Data.Text (Text) |
14 | 14 | import qualified Data.Text as T |
15 | 15 | import qualified Data.Text.IO as T |
16 | 16 | import qualified Ide.Plugin.Splice as Splice |
17 | 17 | import Ide.Plugin.Splice.Types |
18 | | -import System.Directory |
19 | 18 | import System.FilePath |
20 | | -import System.Time.Extra (sleep) |
21 | 19 | import Test.Hls |
22 | 20 |
|
23 | 21 | main :: IO () |
24 | 22 | main = defaultTestRunner tests |
25 | 23 |
|
26 | | -plugin :: PluginDescriptor IdeState |
27 | | -plugin = Splice.descriptor "splice" |
| 24 | +splicePlugin :: PluginDescriptor IdeState |
| 25 | +splicePlugin = Splice.descriptor "splice" |
28 | 26 |
|
29 | 27 | tests :: TestTree |
30 | | -tests = |
31 | | - testGroup |
32 | | - "splice" |
33 | | - [ goldenTest "TSimpleExp.hs" Inplace 6 15 |
34 | | - , goldenTest "TSimpleExp.hs" Inplace 6 24 |
35 | | - , goldenTest "TTypeAppExp.hs" Inplace 7 5 |
36 | | - , goldenTest "TErrorExp.hs" Inplace 6 15 |
37 | | - , goldenTest "TErrorExp.hs" Inplace 6 51 |
38 | | - , goldenTest "TQQExp.hs" Inplace 6 17 |
39 | | - , goldenTest "TQQExp.hs" Inplace 6 25 |
40 | | - , goldenTest "TQQExpError.hs" Inplace 6 13 |
41 | | - , goldenTest "TQQExpError.hs" Inplace 6 22 |
42 | | - , testGroup "Pattern Splices" |
43 | | - [ goldenTest "TSimplePat.hs" Inplace 6 3 |
44 | | - , goldenTest "TSimplePat.hs" Inplace 6 22 |
45 | | - , goldenTest "TSimplePat.hs" Inplace 6 3 |
46 | | - , goldenTest "TSimplePat.hs" Inplace 6 22 |
47 | | - , goldenTest "TErrorPat.hs" Inplace 6 3 |
48 | | - , goldenTest "TErrorPat.hs" Inplace 6 18 |
49 | | - , goldenTest "TQQPat.hs" Inplace 6 3 |
50 | | - , goldenTest "TQQPat.hs" Inplace 6 11 |
51 | | - , goldenTest "TQQPatError.hs" Inplace 6 3 |
52 | | - , goldenTest "TQQPatError.hs" Inplace 6 11 |
53 | | - ] |
54 | | - , goldenTest "TSimpleType.hs" Inplace 5 12 |
55 | | - , goldenTest "TSimpleType.hs" Inplace 5 22 |
56 | | - , goldenTest "TTypeTypeError.hs" Inplace 7 12 |
57 | | - , goldenTest "TTypeTypeError.hs" Inplace 7 52 |
58 | | - , goldenTest "TQQType.hs" Inplace 8 19 |
59 | | - , goldenTest "TQQType.hs" Inplace 8 28 |
60 | | - , goldenTest "TQQTypeTypeError.hs" Inplace 8 19 |
61 | | - , goldenTest "TQQTypeTypeError.hs" Inplace 8 28 |
62 | | - , goldenTest "TSimpleDecl.hs" Inplace 8 1 |
63 | | - , goldenTest "TQQDecl.hs" Inplace 5 1 |
64 | | - , goldenTestWithEdit "TTypeKindError.hs" Inplace 7 9 |
65 | | - , goldenTestWithEdit "TDeclKindError.hs" Inplace 8 1 |
66 | | - ] |
| 28 | +tests = testGroup "splice" |
| 29 | + [ goldenTest "TSimpleExp" Inplace 6 15 |
| 30 | + , goldenTest "TSimpleExp" Inplace 6 24 |
| 31 | + , goldenTest "TTypeAppExp" Inplace 7 5 |
| 32 | + , goldenTest "TErrorExp" Inplace 6 15 |
| 33 | + , goldenTest "TErrorExp" Inplace 6 51 |
| 34 | + , goldenTest "TQQExp" Inplace 6 17 |
| 35 | + , goldenTest "TQQExp" Inplace 6 25 |
| 36 | + , goldenTest "TQQExpError" Inplace 6 13 |
| 37 | + , goldenTest "TQQExpError" Inplace 6 22 |
| 38 | + , testGroup "Pattern Splices" |
| 39 | + [ goldenTest "TSimplePat" Inplace 6 3 |
| 40 | + , goldenTest "TSimplePat" Inplace 6 22 |
| 41 | + , goldenTest "TSimplePat" Inplace 6 3 |
| 42 | + , goldenTest "TSimplePat" Inplace 6 22 |
| 43 | + , goldenTest "TErrorPat" Inplace 6 3 |
| 44 | + , goldenTest "TErrorPat" Inplace 6 18 |
| 45 | + , goldenTest "TQQPat" Inplace 6 3 |
| 46 | + , goldenTest "TQQPat" Inplace 6 11 |
| 47 | + , goldenTest "TQQPatError" Inplace 6 3 |
| 48 | + , goldenTest "TQQPatError" Inplace 6 11 |
| 49 | + ] |
| 50 | + , goldenTest "TSimpleType" Inplace 5 12 |
| 51 | + , goldenTest "TSimpleType" Inplace 5 22 |
| 52 | + , goldenTest "TTypeTypeError" Inplace 7 12 |
| 53 | + , goldenTest "TTypeTypeError" Inplace 7 52 |
| 54 | + , goldenTest "TQQType" Inplace 8 19 |
| 55 | + , goldenTest "TQQType" Inplace 8 28 |
| 56 | + , goldenTest "TQQTypeTypeError" Inplace 8 19 |
| 57 | + , goldenTest "TQQTypeTypeError" Inplace 8 28 |
| 58 | + , goldenTest "TSimpleDecl" Inplace 8 1 |
| 59 | + , goldenTest "TQQDecl" Inplace 5 1 |
| 60 | + , goldenTestWithEdit "TTypeKindError" Inplace 7 9 |
| 61 | + , goldenTestWithEdit "TDeclKindError" Inplace 8 1 |
| 62 | + ] |
67 | 63 |
|
68 | 64 | goldenTest :: FilePath -> ExpandStyle -> Int -> Int -> TestTree |
69 | | -goldenTest input tc line col = |
70 | | - testCase (input <> " (golden)") $ do |
71 | | - runSessionWithServer plugin spliceTestPath $ do |
72 | | - doc <- openDoc input "haskell" |
73 | | - _ <- waitForDiagnostics |
74 | | - actions <- getCodeActions doc $ pointRange line col |
75 | | - case find ((== Just (toExpandCmdTitle tc)) . codeActionTitle) actions of |
76 | | - Just (InR CodeAction {_command = Just c}) -> do |
77 | | - executeCommand c |
78 | | - _resp <- skipManyTill anyMessage (message SWorkspaceApplyEdit) |
79 | | - edited <- documentContents doc |
80 | | - let expected_name = input <.> "expected" |
81 | | - -- Write golden tests if they don't already exist |
82 | | - liftIO $ |
83 | | - (doesFileExist expected_name >>=) $ |
84 | | - flip unless $ do |
85 | | - T.writeFile expected_name edited |
86 | | - expected <- liftIO $ T.readFile expected_name |
87 | | - liftIO $ edited @?= expected |
88 | | - _ -> liftIO $ assertFailure "No CodeAction detected" |
| 65 | +goldenTest fp tc line col = |
| 66 | + goldenWithHaskellDoc splicePlugin (fp <> " (golden)") testDataDir fp "expected" "hs" $ \doc -> do |
| 67 | + _ <- waitForDiagnostics |
| 68 | + actions <- getCodeActions doc $ pointRange line col |
| 69 | + case find ((== Just (toExpandCmdTitle tc)) . codeActionTitle) actions of |
| 70 | + Just (InR CodeAction {_command = Just c}) -> do |
| 71 | + executeCommand c |
| 72 | + void $ skipManyTill anyMessage (message SWorkspaceApplyEdit) |
| 73 | + _ -> liftIO $ assertFailure "No CodeAction detected" |
89 | 74 |
|
90 | 75 | goldenTestWithEdit :: FilePath -> ExpandStyle -> Int -> Int -> TestTree |
91 | | -goldenTestWithEdit input tc line col = |
92 | | - testCase (input <> " (golden)") $ do |
93 | | - runSessionWithServer plugin spliceTestPath $ do |
94 | | - doc <- openDoc input "haskell" |
95 | | - orig <- documentContents doc |
96 | | - let lns = T.lines orig |
97 | | - theRange = |
98 | | - Range |
99 | | - { _start = Position 0 0 |
100 | | - , _end = Position (length lns + 1) 1 |
101 | | - } |
102 | | - waitForProgressDone -- cradle |
103 | | - waitForProgressDone |
104 | | - alt <- liftIO $ T.readFile (input <.> "error") |
105 | | - void $ applyEdit doc $ TextEdit theRange alt |
106 | | - changeDoc doc [TextDocumentContentChangeEvent (Just theRange) Nothing alt] |
107 | | - void waitForDiagnostics |
108 | | - actions <- getCodeActions doc $ pointRange line col |
109 | | - case find ((== Just (toExpandCmdTitle tc)) . codeActionTitle) actions of |
110 | | - Just (InR CodeAction {_command = Just c}) -> do |
111 | | - executeCommand c |
112 | | - _resp <- skipManyTill anyMessage (message SWorkspaceApplyEdit) |
113 | | - edited <- documentContents doc |
114 | | - let expected_name = input <.> "expected" |
115 | | - -- Write golden tests if they don't already exist |
116 | | - liftIO $ |
117 | | - (doesFileExist expected_name >>=) $ |
118 | | - flip unless $ do |
119 | | - T.writeFile expected_name edited |
120 | | - expected <- liftIO $ T.readFile expected_name |
121 | | - liftIO $ edited @?= expected |
122 | | - _ -> liftIO $ assertFailure "No CodeAction detected" |
| 76 | +goldenTestWithEdit fp tc line col = |
| 77 | + goldenWithHaskellDoc splicePlugin (fp <> " (golden)") testDataDir fp "expected" "hs" $ \doc -> do |
| 78 | + orig <- documentContents doc |
| 79 | + let |
| 80 | + lns = T.lines orig |
| 81 | + theRange = |
| 82 | + Range |
| 83 | + { _start = Position 0 0 |
| 84 | + , _end = Position (length lns + 1) 1 |
| 85 | + } |
| 86 | + waitForProgressDone -- cradle |
| 87 | + waitForProgressDone |
| 88 | + alt <- liftIO $ T.readFile (fp <.> "error.hs") |
| 89 | + void $ applyEdit doc $ TextEdit theRange alt |
| 90 | + changeDoc doc [TextDocumentContentChangeEvent (Just theRange) Nothing alt] |
| 91 | + void waitForDiagnostics |
| 92 | + actions <- getCodeActions doc $ pointRange line col |
| 93 | + case find ((== Just (toExpandCmdTitle tc)) . codeActionTitle) actions of |
| 94 | + Just (InR CodeAction {_command = Just c}) -> do |
| 95 | + executeCommand c |
| 96 | + void $ skipManyTill anyMessage (message SWorkspaceApplyEdit) |
| 97 | + _ -> liftIO $ assertFailure "No CodeAction detected" |
123 | 98 |
|
124 | | -spliceTestPath :: FilePath |
125 | | -spliceTestPath = "test" </> "testdata" |
| 99 | +testDataDir :: FilePath |
| 100 | +testDataDir = "test" </> "testdata" |
126 | 101 |
|
127 | 102 | pointRange :: Int -> Int -> Range |
128 | | -pointRange |
129 | | - (subtract 1 -> line) |
130 | | - (subtract 1 -> col) = |
131 | | - Range (Position line col) (Position line $ col + 1) |
| 103 | +pointRange (subtract 1 -> line) (subtract 1 -> col) = |
| 104 | + Range (Position line col) (Position line $ col + 1) |
132 | 105 |
|
133 | 106 | -- | Get the title of a code action. |
134 | 107 | codeActionTitle :: (Command |? CodeAction) -> Maybe Text |
135 | | -codeActionTitle InL{} = Nothing |
136 | | -codeActionTitle (InR(CodeAction title _ _ _ _ _ _ _)) = Just title |
| 108 | +codeActionTitle InL {} = Nothing |
| 109 | +codeActionTitle (InR CodeAction {_title}) = Just _title |
0 commit comments