{-# LANGUAGE OverloadedStrings #-}
module Symbol (tests) where
import Control.Lens (_Just, ix, (^?))
import Data.List
import Language.LSP.Protocol.Capabilities
import qualified Language.LSP.Protocol.Lens as L
import Language.LSP.Test as Test
import Test.Hls
import Test.Hls.Command
tests :: TestTree
tests = testGroup "document symbols" [
pre310Tests
, v310Tests
]
v310Tests :: TestTree
v310Tests = testGroup "3.10 hierarchical document symbols" [
testCase "provides nested data types and constructors" $ runSession hlsCommand fullCaps "test/testdata" $ do
doc <- openDoc "Symbols.hs" "haskell"
Right symbs <- getDocumentSymbols doc
let myData = DocumentSymbol "MyData" Nothing SymbolKind_Struct Nothing Nothing myDataR myDataSR (Just [a, b])
a = DocumentSymbol "A" Nothing SymbolKind_Constructor Nothing Nothing aR aSR Nothing
b = DocumentSymbol "B" Nothing SymbolKind_Constructor Nothing Nothing bR bSR Nothing
let myData' = symbs ^? ix 0 . L.children . _Just . ix 2
liftIO $ Just myData == myData' @? "Contains symbol"
, ignoreTestBecause "extracting symbols from nested wheres not supported" $ testCase "provides nested where functions" $ runSession hlsCommand fullCaps "test/testdata" $ do
doc <- openDoc "Symbols.hs" "haskell"
Right symbs <- getDocumentSymbols doc
let foo = DocumentSymbol "foo" Nothing SymbolKind_Function Nothing Nothing fooR fooSR (Just [bar])
bar = DocumentSymbol "bar" Nothing SymbolKind_Function Nothing Nothing barR barSR (Just [dog, cat])
dog = DocumentSymbol "dog" Nothing SymbolKind_Variable Nothing Nothing dogR dogSR (Just mempty)
cat = DocumentSymbol "cat" Nothing SymbolKind_Variable Nothing Nothing catR catSR (Just mempty)
let foo' = symbs ^? ix 0 . L.children . _Just . ix 1
liftIO $ Just foo == foo' @? "Contains symbol"
, ignoreTestBecause "extracting pattern synonym symbols not supported" $ testCase "provides pattern synonyms" $ runSession hlsCommand fullCaps "test/testdata" $ do
doc <- openDoc "Symbols.hs" "haskell"
Right symbs <- getDocumentSymbols doc
let testPattern = DocumentSymbol "TestPattern"
Nothing SymbolKind_Function Nothing Nothing testPatternR testPatternSR (Just mempty)
let testPattern' = symbs ^? ix 0 . L.children . _Just . ix 3
liftIO $ Just testPattern == testPattern' @? "Contains symbol"
, testCase "provides imports" $ runSession hlsCommand fullCaps "test/testdata" $ do
doc <- openDoc "Symbols.hs" "haskell"
Right symbs <- getDocumentSymbols doc
let imports = DocumentSymbol "imports" Nothing SymbolKind_Module Nothing Nothing importsR importsSR (Just [importDataMaybe])
importDataMaybe = DocumentSymbol "import Data.Maybe" Nothing SymbolKind_Module Nothing Nothing importDataMaybeR importDataMaybeSR Nothing
let imports' = symbs ^? ix 0 . L.children . _Just . ix 0
liftIO $ Just imports == imports' @? "Contains symbol"
]
pre310Tests :: TestTree
pre310Tests = testGroup "pre 3.10 symbol information" [
testCase "provides nested data types and constructors" $ runSession hlsCommand oldCaps "test/testdata" $ do
doc@(TextDocumentIdentifier testUri) <- openDoc "Symbols.hs" "haskell"
Left symbs <- getDocumentSymbols doc
let myData = SymbolInformation "MyData" SymbolKind_Struct Nothing (Just "Symbols") Nothing (Location testUri myDataR)
a = SymbolInformation "A" SymbolKind_Constructor Nothing (Just "MyData") Nothing (Location testUri aR)
b = SymbolInformation "B" SymbolKind_Constructor Nothing (Just "MyData") Nothing (Location testUri bR)
liftIO $ [myData, a, b] `isInfixOf` symbs @? "Contains symbols"
, ignoreTestBecause "extracting symbols from nested wheres not supported" $ testCase "provides nested where functions" $ runSession hlsCommand oldCaps "test/testdata" $ do
doc@(TextDocumentIdentifier testUri) <- openDoc "Symbols.hs" "haskell"
Left symbs <- getDocumentSymbols doc
let foo = SymbolInformation "foo" SymbolKind_Function Nothing (Just "Symbols") Nothing (Location testUri fooR)
bar = SymbolInformation "bar" SymbolKind_Function Nothing (Just "foo") Nothing (Location testUri barR)
dog = SymbolInformation "dog" SymbolKind_Variable Nothing (Just "bar") Nothing (Location testUri dogR)
cat = SymbolInformation "cat" SymbolKind_Variable Nothing (Just "bar") Nothing (Location testUri catR)
-- Order is important!
liftIO $ [foo, bar, dog, cat] `isInfixOf` symbs @? "Contains symbols"
, ignoreTestBecause "extracting pattern synonym symbols not supported" $ testCase "provides pattern synonyms" $ runSession hlsCommand oldCaps "test/testdata" $ do
doc@(TextDocumentIdentifier testUri) <- openDoc "Symbols.hs" "haskell"
Left symbs <- getDocumentSymbols doc
let testPattern = SymbolInformation "TestPattern"
SymbolKind_Function Nothing (Just "Symbols") Nothing (Location testUri testPatternR)
liftIO $ testPattern `elem` symbs @? "Contains symbols"
, testCase "provides imports" $ runSession hlsCommand oldCaps "test/testdata" $ do
doc@(TextDocumentIdentifier testUri) <- openDoc "Symbols.hs" "haskell"
Left symbs <- getDocumentSymbols doc
let imports = SymbolInformation "imports" SymbolKind_Module Nothing (Just "Symbols") Nothing (Location testUri importsR)
importDataMaybe = SymbolInformation "import Data.Maybe" SymbolKind_Module Nothing (Just "imports") Nothing (Location testUri importDataMaybeR)
liftIO $ [imports, importDataMaybe] `isInfixOf` symbs @? "Contains symbol"
]
oldCaps :: ClientCapabilities
oldCaps = capsForVersion (LSPVersion 3 9)
-- Some common ranges and selection ranges in Symbols.hs
importsR :: Range
importsR = Range (Position 3 0) (Position 3 17)
importsSR :: Range
importsSR = Range (Position 3 0) (Position 3 17)
importDataMaybeR :: Range
importDataMaybeR = Range (Position 3 0) (Position 3 17)
importDataMaybeSR :: Range
importDataMaybeSR = Range (Position 3 0) (Position 3 17)
fooSR :: Range
fooSR = Range (Position 5 0) (Position 7 43)
fooR :: Range
fooR = Range (Position 5 0) (Position 7 43)
barSR :: Range
barSR = Range (Position 6 8) (Position 6 11)
barR :: Range
barR = Range (Position 6 8) (Position 7 43)
dogSR :: Range
dogSR = Range (Position 7 17) (Position 7 20)
dogR :: Range
dogR = Range (Position 7 16) (Position 7 43)
catSR :: Range
catSR = Range (Position 7 22) (Position 7 25)
catR :: Range
catR = Range (Position 7 16) (Position 7 43)
myDataSR :: Range
myDataSR = Range (Position 9 0) (Position 10 22)
myDataR :: Range
myDataR = Range (Position 9 0) (Position 10 22)
aSR :: Range
aSR = Range (Position 9 14) (Position 9 15)
aR :: Range
aR = Range (Position 9 14) (Position 9 19)
bSR :: Range
bSR = Range (Position 10 14) (Position 10 15)
bR :: Range
bR = Range (Position 10 14) (Position 10 22)
testPatternSR :: Range
testPatternSR = Range (Position 13 8) (Position 13 19)
testPatternR :: Range
testPatternR = Range (Position 13 0) (Position 13 27)