Skip to content

Commit 8ef854a

Browse files
soulomoonsoulomoon
authored
[Migrate OutlineTests.hs ferenceTests.hs] part of 4173 Migrate ghcide tests to hls test utils (#4182)
* move ghcide-tests to haskell-language-server.cabal and make it depend on hls-test-utils * migrate initializeResponseTests * cleanup * migrate initializeResponseTests * remove duplication * fix test name * migrate referenceTests * fix github action * fix test dir location * Fix hls-semantic-tests * fix 9.2 build * cleanup * add doc for CopiedDirectory * only copy files in git * cleanup * add --others to show un staged files * cleanup * cleanup * copy dir recursively * use wrapper version to provide file system
1 parent a6f0008 commit 8ef854a

File tree

7 files changed

+390
-334
lines changed

7 files changed

+390
-334
lines changed

‎ghcide/test/exe/Config.hs

+22-3
Original file line numberDiff line numberDiff line change
@@ -1,9 +1,12 @@
1+
{-# LANGUAGE PatternSynonyms #-}
2+
13
module Config where
4+
25
import Ide.Types (defaultPluginDescriptor)
36
import System.FilePath ((</>))
4-
import Test.Hls (PluginTestDescriptor,
5-
mkPluginTestDescriptor)
7+
import Test.Hls
68
import qualified Test.Hls.FileSystem as FS
9+
import Test.Hls.FileSystem (FileSystem)
710

811
testDataDir :: FilePath
912
testDataDir = "ghcide" </> "test" </> "data"
@@ -13,4 +16,20 @@ mkIdeTestFs = FS.mkVirtualFileTree testDataDir
1316

1417
-- * A dummy plugin for testing ghcIde
1518
dummyPlugin :: PluginTestDescriptor ()
16-
dummyPlugin = mkPluginTestDescriptor (\_ pid ->defaultPluginDescriptor pid "dummyTestPlugin") "core"
19+
dummyPlugin = mkPluginTestDescriptor (\_ pid -> defaultPluginDescriptor pid "dummyTestPlugin") "core"
20+
21+
runWithDummyPlugin :: FS.VirtualFileTree -> Session a -> IO a
22+
runWithDummyPlugin = runSessionWithServerInTmpDir def dummyPlugin
23+
24+
runWithDummyPlugin' :: FS.VirtualFileTree -> (FileSystem -> Session a) -> IO a
25+
runWithDummyPlugin' = runSessionWithServerInTmpDirCont' def dummyPlugin
26+
27+
-- testSessionWithCorePlugin ::(TestRunner cont ()) => TestName -> FS.VirtualFileTree -> cont -> TestTree
28+
testWithDummyPlugin :: String -> FS.VirtualFileTree -> Session () -> TestTree
29+
testWithDummyPlugin caseName vfs = testCase caseName . runWithDummyPlugin vfs
30+
31+
testWithDummyPlugin' :: String -> FS.VirtualFileTree -> (FileSystem -> Session ()) -> TestTree
32+
testWithDummyPlugin' caseName vfs = testCase caseName . runWithDummyPlugin' vfs
33+
34+
pattern R :: UInt -> UInt -> UInt -> UInt -> Range
35+
pattern R x y x' y' = Range (Position x y) (Position x' y')

‎ghcide/test/exe/InitializeResponseTests.hs

+3-2
Original file line numberDiff line numberDiff line change
@@ -13,7 +13,8 @@ import qualified Language.LSP.Protocol.Lens as L
1313
import Language.LSP.Protocol.Message
1414
import Language.LSP.Test
1515

16-
import Config (dummyPlugin, mkIdeTestFs)
16+
import Config (dummyPlugin, mkIdeTestFs,
17+
runWithDummyPlugin)
1718
import Control.Lens ((^.))
1819
import Development.IDE.Plugin.Test (blockCommandId)
1920
import Test.Hls
@@ -84,7 +85,7 @@ tests = withResource acquire release tests where
8485
innerCaps (TResponseMessage _ _ (Left _)) = error "Initialization error"
8586

8687
acquire :: IO (TResponseMessage Method_Initialize)
87-
acquire = runSessionWithServerInTmpDir def dummyPlugin (mkIdeTestFs []) initializeResponse
88+
acquire = runWithDummyPlugin (mkIdeTestFs []) initializeResponse
8889

8990
release :: TResponseMessage Method_Initialize -> IO ()
9091
release = mempty

‎ghcide/test/exe/OutlineTests.hs

+138-175
Original file line numberDiff line numberDiff line change
@@ -1,189 +1,152 @@
1+
{-# LANGUAGE OverloadedStrings #-}
2+
{-# LANGUAGE TypeFamilies #-}
13

24
module OutlineTests (tests) where
35

6+
import Config
47
import Control.Monad.IO.Class (liftIO)
8+
import Data.Text (Text)
59
import qualified Data.Text as T
610
import Language.LSP.Protocol.Types hiding (SemanticTokenAbsolute (..),
711
SemanticTokenRelative (..),
812
SemanticTokensEdit (..), mkRange)
913
import Language.LSP.Test
14+
import Test.Hls.FileSystem (file, text)
1015
import Test.Tasty
1116
import Test.Tasty.HUnit
12-
import TestUtils
1317

14-
tests :: TestTree
15-
tests = testGroup
16-
"outline"
17-
[ testSessionWait "type class" $ do
18-
let source = T.unlines ["module A where", "class A a where a :: a -> Bool"]
19-
docId <- createDoc "A.hs" "haskell" source
20-
symbols <- getDocumentSymbols docId
21-
liftIO $ symbols @?= Right
22-
[ moduleSymbol
23-
"A"
24-
(R 0 7 0 8)
25-
[ classSymbol "A a"
26-
(R 1 0 1 30)
27-
[docSymbol' "a" SymbolKind_Method (R 1 16 1 30) (R 1 16 1 17)]
28-
]
29-
]
30-
, testSessionWait "type class instance " $ do
31-
let source = T.unlines ["class A a where", "instance A () where"]
32-
docId <- createDoc "A.hs" "haskell" source
33-
symbols <- getDocumentSymbols docId
34-
liftIO $ symbols @?= Right
35-
[ classSymbol "A a" (R 0 0 0 15) []
36-
, docSymbol "A ()" SymbolKind_Interface (R 1 0 1 19)
37-
]
38-
, testSessionWait "type family" $ do
39-
let source = T.unlines ["{-# language TypeFamilies #-}", "type family A"]
40-
docId <- createDoc "A.hs" "haskell" source
41-
symbols <- getDocumentSymbols docId
42-
liftIO $ symbols @?= Right [docSymbolD "A" "type family" SymbolKind_Function (R 1 0 1 13)]
43-
, testSessionWait "type family instance " $ do
44-
let source = T.unlines
45-
[ "{-# language TypeFamilies #-}"
46-
, "type family A a"
47-
, "type instance A () = ()"
48-
]
49-
docId <- createDoc "A.hs" "haskell" source
50-
symbols <- getDocumentSymbols docId
51-
liftIO $ symbols @?= Right
52-
[ docSymbolD "A a" "type family" SymbolKind_Function (R 1 0 1 15)
53-
, docSymbol "A ()" SymbolKind_Interface (R 2 0 2 23)
54-
]
55-
, testSessionWait "data family" $ do
56-
let source = T.unlines ["{-# language TypeFamilies #-}", "data family A"]
57-
docId <- createDoc "A.hs" "haskell" source
58-
symbols <- getDocumentSymbols docId
59-
liftIO $ symbols @?= Right [docSymbolD "A" "data family" SymbolKind_Function (R 1 0 1 11)]
60-
, testSessionWait "data family instance " $ do
61-
let source = T.unlines
62-
[ "{-# language TypeFamilies #-}"
63-
, "data family A a"
64-
, "data instance A () = A ()"
65-
]
66-
docId <- createDoc "A.hs" "haskell" source
67-
symbols <- getDocumentSymbols docId
68-
liftIO $ symbols @?= Right
69-
[ docSymbolD "A a" "data family" SymbolKind_Function (R 1 0 1 11)
70-
, docSymbol "A ()" SymbolKind_Interface (R 2 0 2 25)
71-
]
72-
, testSessionWait "constant" $ do
73-
let source = T.unlines ["a = ()"]
74-
docId <- createDoc "A.hs" "haskell" source
75-
symbols <- getDocumentSymbols docId
76-
liftIO $ symbols @?= Right
77-
[docSymbol "a" SymbolKind_Function (R 0 0 0 6)]
78-
, testSessionWait "pattern" $ do
79-
let source = T.unlines ["Just foo = Just 21"]
80-
docId <- createDoc "A.hs" "haskell" source
81-
symbols <- getDocumentSymbols docId
82-
liftIO $ symbols @?= Right
83-
[docSymbol "Just foo" SymbolKind_Function (R 0 0 0 18)]
84-
, testSessionWait "pattern with type signature" $ do
85-
let source = T.unlines ["{-# language ScopedTypeVariables #-}", "a :: () = ()"]
86-
docId <- createDoc "A.hs" "haskell" source
87-
symbols <- getDocumentSymbols docId
88-
liftIO $ symbols @?= Right
89-
[docSymbol "a :: ()" SymbolKind_Function (R 1 0 1 12)]
90-
, testSessionWait "function" $ do
91-
let source = T.unlines ["a _x = ()"]
92-
docId <- createDoc "A.hs" "haskell" source
93-
symbols <- getDocumentSymbols docId
94-
liftIO $ symbols @?= Right [docSymbol "a" SymbolKind_Function (R 0 0 0 9)]
95-
, testSessionWait "type synonym" $ do
96-
let source = T.unlines ["type A = Bool"]
97-
docId <- createDoc "A.hs" "haskell" source
98-
symbols <- getDocumentSymbols docId
99-
liftIO $ symbols @?= Right
100-
[docSymbol' "A" SymbolKind_TypeParameter (R 0 0 0 13) (R 0 5 0 6)]
101-
, testSessionWait "datatype" $ do
102-
let source = T.unlines ["data A = C"]
103-
docId <- createDoc "A.hs" "haskell" source
18+
testSymbols :: (HasCallStack) => TestName -> FilePath -> [Text] -> [DocumentSymbol] -> TestTree
19+
testSymbols testName path content expectedSymbols =
20+
testCase testName $ runWithDummyPlugin (mkIdeTestFs [file path (text $ T.unlines content)]) $ do
21+
docId <- openDoc path "haskell"
10422
symbols <- getDocumentSymbols docId
105-
liftIO $ symbols @?= Right
106-
[ docSymbolWithChildren "A"
107-
SymbolKind_Struct
108-
(R 0 0 0 10)
109-
[docSymbol "C" SymbolKind_Constructor (R 0 9 0 10)]
110-
]
111-
, testSessionWait "record fields" $ do
112-
let source = T.unlines ["data A = B {", " x :: Int", " , y :: Int}"]
113-
docId <- createDoc "A.hs" "haskell" source
114-
symbols <- getDocumentSymbols docId
115-
liftIO $ symbols @?= Right
116-
[ docSymbolWithChildren "A" SymbolKind_Struct (R 0 0 2 13)
117-
[ docSymbolWithChildren' "B" SymbolKind_Constructor (R 0 9 2 13) (R 0 9 0 10)
118-
[ docSymbol "x" SymbolKind_Field (R 1 2 1 3)
119-
, docSymbol "y" SymbolKind_Field (R 2 4 2 5)
23+
liftIO $ symbols @?= Right expectedSymbols
24+
25+
testSymbolsA :: (HasCallStack) => TestName -> [Text] -> [DocumentSymbol] -> TestTree
26+
testSymbolsA testName content expectedSymbols =
27+
testSymbols testName "A.hs" content expectedSymbols
28+
29+
tests :: TestTree
30+
tests =
31+
testGroup
32+
"outline"
33+
[ testSymbolsA
34+
"type class:"
35+
["module A where", "class A a where a :: a -> Bool"]
36+
[ moduleSymbol
37+
"A"
38+
(R 0 7 0 8)
39+
[ classSymbol
40+
"A a"
41+
(R 1 0 1 30)
42+
[docSymbol' "a" SymbolKind_Method (R 1 16 1 30) (R 1 16 1 17)]
12043
]
121-
]
122-
]
123-
, testSessionWait "import" $ do
124-
let source = T.unlines ["import Data.Maybe ()"]
125-
docId <- createDoc "A.hs" "haskell" source
126-
symbols <- getDocumentSymbols docId
127-
liftIO $ symbols @?= Right
128-
[docSymbolWithChildren "imports"
129-
SymbolKind_Module
130-
(R 0 0 0 20)
131-
[ docSymbol "import Data.Maybe" SymbolKind_Module (R 0 0 0 20)
132-
]
133-
]
134-
, testSessionWait "multiple import" $ do
135-
let source = T.unlines ["", "import Data.Maybe ()", "", "import Control.Exception ()", ""]
136-
docId <- createDoc "A.hs" "haskell" source
137-
symbols <- getDocumentSymbols docId
138-
liftIO $ symbols @?= Right
139-
[docSymbolWithChildren "imports"
140-
SymbolKind_Module
141-
(R 1 0 3 27)
142-
[ docSymbol "import Data.Maybe" SymbolKind_Module (R 1 0 1 20)
143-
, docSymbol "import Control.Exception" SymbolKind_Module (R 3 0 3 27)
144-
]
145-
]
146-
, testSessionWait "foreign import" $ do
147-
let source = T.unlines
148-
[ "{-# language ForeignFunctionInterface #-}"
149-
, "foreign import ccall \"a\" a :: Int"
150-
]
151-
docId <- createDoc "A.hs" "haskell" source
152-
symbols <- getDocumentSymbols docId
153-
liftIO $ symbols @?= Right [docSymbolD "a" "import" SymbolKind_Object (R 1 0 1 33)]
154-
, testSessionWait "foreign export" $ do
155-
let source = T.unlines
156-
[ "{-# language ForeignFunctionInterface #-}"
157-
, "foreign export ccall odd :: Int -> Bool"
158-
]
159-
docId <- createDoc "A.hs" "haskell" source
160-
symbols <- getDocumentSymbols docId
161-
liftIO $ symbols @?= Right [docSymbolD "odd" "export" SymbolKind_Object (R 1 0 1 39)]
162-
]
163-
where
164-
docSymbol name kind loc =
165-
DocumentSymbol name Nothing kind Nothing Nothing loc loc Nothing
166-
docSymbol' name kind loc selectionLoc =
167-
DocumentSymbol name Nothing kind Nothing Nothing loc selectionLoc Nothing
168-
docSymbolD name detail kind loc =
169-
DocumentSymbol name (Just detail) kind Nothing Nothing loc loc Nothing
170-
docSymbolWithChildren name kind loc cc =
171-
DocumentSymbol name Nothing kind Nothing Nothing loc loc (Just cc)
172-
docSymbolWithChildren' name kind loc selectionLoc cc =
173-
DocumentSymbol name Nothing kind Nothing Nothing loc selectionLoc (Just cc)
174-
moduleSymbol name loc cc = DocumentSymbol name
175-
Nothing
176-
SymbolKind_File
177-
Nothing
178-
Nothing
179-
(R 0 0 maxBound 0)
180-
loc
181-
(Just cc)
182-
classSymbol name loc cc = DocumentSymbol name
183-
(Just "class")
184-
SymbolKind_Interface
185-
Nothing
186-
Nothing
187-
loc
188-
loc
189-
(Just cc)
44+
],
45+
testSymbolsA
46+
"type class instance "
47+
["class A a where", "instance A () where"]
48+
[ classSymbol "A a" (R 0 0 0 15) [],
49+
docSymbol "A ()" SymbolKind_Interface (R 1 0 1 19)
50+
],
51+
testSymbolsA "type family" ["{-# language TypeFamilies #-}", "type family A"] [docSymbolD "A" "type family" SymbolKind_Function (R 1 0 1 13)],
52+
testSymbolsA
53+
"type family instance "
54+
["{-# language TypeFamilies #-}", "type family A a", "type instance A () = ()"]
55+
[ docSymbolD "A a" "type family" SymbolKind_Function (R 1 0 1 15),
56+
docSymbol "A ()" SymbolKind_Interface (R 2 0 2 23)
57+
],
58+
testSymbolsA "data family" ["{-# language TypeFamilies #-}", "data family A"] [docSymbolD "A" "data family" SymbolKind_Function (R 1 0 1 11)],
59+
testSymbolsA
60+
"data family instance "
61+
["{-# language TypeFamilies #-}", "data family A a", "data instance A () = A ()"]
62+
[ docSymbolD "A a" "data family" SymbolKind_Function (R 1 0 1 11),
63+
docSymbol "A ()" SymbolKind_Interface (R 2 0 2 25)
64+
],
65+
testSymbolsA "constant" ["a = ()"] [docSymbol "a" SymbolKind_Function (R 0 0 0 6)],
66+
testSymbolsA "pattern" ["Just foo = Just 21"] [docSymbol "Just foo" SymbolKind_Function (R 0 0 0 18)],
67+
testSymbolsA "pattern with type signature" ["{-# language ScopedTypeVariables #-}", "a :: () = ()"] [docSymbol "a :: ()" SymbolKind_Function (R 1 0 1 12)],
68+
testSymbolsA "function" ["a _x = ()"] [docSymbol "a" SymbolKind_Function (R 0 0 0 9)],
69+
testSymbolsA "type synonym" ["type A = Bool"] [docSymbol' "A" SymbolKind_TypeParameter (R 0 0 0 13) (R 0 5 0 6)],
70+
testSymbolsA "datatype" ["data A = C"] [docSymbolWithChildren "A" SymbolKind_Struct (R 0 0 0 10) [docSymbol "C" SymbolKind_Constructor (R 0 9 0 10)]],
71+
testSymbolsA
72+
"record fields"
73+
["data A = B {", " x :: Int", " , y :: Int}"]
74+
[ docSymbolWithChildren
75+
"A"
76+
SymbolKind_Struct
77+
(R 0 0 2 13)
78+
[ docSymbolWithChildren'
79+
"B"
80+
SymbolKind_Constructor
81+
(R 0 9 2 13)
82+
(R 0 9 0 10)
83+
[ docSymbol "x" SymbolKind_Field (R 1 2 1 3),
84+
docSymbol "y" SymbolKind_Field (R 2 4 2 5)
85+
]
86+
]
87+
],
88+
testSymbolsA
89+
"import"
90+
["import Data.Maybe ()"]
91+
[ docSymbolWithChildren
92+
"imports"
93+
SymbolKind_Module
94+
(R 0 0 0 20)
95+
[ docSymbol "import Data.Maybe" SymbolKind_Module (R 0 0 0 20)
96+
]
97+
],
98+
testSymbolsA
99+
"multiple import"
100+
["", "import Data.Maybe ()", "", "import Control.Exception ()", ""]
101+
[ docSymbolWithChildren
102+
"imports"
103+
SymbolKind_Module
104+
(R 1 0 3 27)
105+
[ docSymbol "import Data.Maybe" SymbolKind_Module (R 1 0 1 20),
106+
docSymbol "import Control.Exception" SymbolKind_Module (R 3 0 3 27)
107+
]
108+
],
109+
testSymbolsA
110+
"foreign import"
111+
[ "{-# language ForeignFunctionInterface #-}",
112+
"foreign import ccall \"a\" a :: Int"
113+
]
114+
[docSymbolD "a" "import" SymbolKind_Object (R 1 0 1 33)],
115+
testSymbolsA
116+
"foreign export"
117+
[ "{-# language ForeignFunctionInterface #-}",
118+
"foreign export ccall odd :: Int -> Bool"
119+
]
120+
[docSymbolD "odd" "export" SymbolKind_Object (R 1 0 1 39)]
121+
]
122+
where
123+
docSymbol name kind loc =
124+
DocumentSymbol name Nothing kind Nothing Nothing loc loc Nothing
125+
docSymbol' name kind loc selectionLoc =
126+
DocumentSymbol name Nothing kind Nothing Nothing loc selectionLoc Nothing
127+
docSymbolD name detail kind loc =
128+
DocumentSymbol name (Just detail) kind Nothing Nothing loc loc Nothing
129+
docSymbolWithChildren name kind loc cc =
130+
DocumentSymbol name Nothing kind Nothing Nothing loc loc (Just cc)
131+
docSymbolWithChildren' name kind loc selectionLoc cc =
132+
DocumentSymbol name Nothing kind Nothing Nothing loc selectionLoc (Just cc)
133+
moduleSymbol name loc cc =
134+
DocumentSymbol
135+
name
136+
Nothing
137+
SymbolKind_File
138+
Nothing
139+
Nothing
140+
(R 0 0 maxBound 0)
141+
loc
142+
(Just cc)
143+
classSymbol name loc cc =
144+
DocumentSymbol
145+
name
146+
(Just "class")
147+
SymbolKind_Interface
148+
Nothing
149+
Nothing
150+
loc
151+
loc
152+
(Just cc)

0 commit comments

Comments
 (0)