{-# LANGUAGE OverloadedStrings #-}
module Symbol (tests) where

import Control.Lens (to, ix, (^?), _Just)
import Control.Monad.IO.Class
import Data.List
import Language.LSP.Test as Test
import Language.LSP.Types
import qualified Language.LSP.Types.Lens as L
import Language.LSP.Types.Capabilities
import Test.Hls.Util
import Test.Tasty
import Test.Tasty.ExpectedFailure (ignoreTestBecause)
import Test.Tasty.HUnit

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"
        Left symbs <- getDocumentSymbols doc

        let myData = DocumentSymbol "MyData" Nothing SkStruct Nothing myDataR myDataSR (Just (List [a, b]))
            a = DocumentSymbol "A" Nothing SkConstructor Nothing aR aSR Nothing
            b = DocumentSymbol "B" Nothing SkConstructor Nothing bR bSR Nothing
        let myData' = symbs ^? ix 0 . L.children . _Just .to fromList . 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"
        Left symbs <- getDocumentSymbols doc

        let foo = DocumentSymbol "foo" Nothing SkFunction Nothing fooR fooSR (Just (List [bar]))
            bar = DocumentSymbol "bar" Nothing SkFunction Nothing barR barSR (Just (List [dog, cat]))
            dog = DocumentSymbol "dog" Nothing SkVariable Nothing dogR dogSR (Just mempty)
            cat = DocumentSymbol "cat" Nothing SkVariable Nothing catR catSR (Just mempty)
        let foo' = symbs ^? ix 0 . L.children . _Just .to fromList . 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"
        Left symbs <- getDocumentSymbols doc

        let testPattern = DocumentSymbol "TestPattern"
                Nothing SkFunction Nothing testPatternR testPatternSR (Just mempty)
        let testPattern' = symbs ^? ix 0 . L.children . _Just .to fromList . ix 3

        liftIO $ Just testPattern == testPattern' @? "Contains symbol"

    , testCase "provides imports" $ runSession hlsCommand fullCaps "test/testdata" $ do
        doc <- openDoc "Symbols.hs" "haskell"
        Left symbs <- getDocumentSymbols doc

        let imports = DocumentSymbol "imports" Nothing SkModule Nothing importsR importsSR (Just (List [importDataMaybe]))
            importDataMaybe = DocumentSymbol "import Data.Maybe" Nothing SkModule Nothing importDataMaybeR importDataMaybeSR Nothing
        let imports' = symbs ^? ix 0 . L.children . _Just .to fromList . 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"
        Right symbs <- getDocumentSymbols doc

        let myData = SymbolInformation "MyData" SkStruct Nothing (Location testUri myDataR) (Just "Symbols")
            a = SymbolInformation "A" SkConstructor Nothing (Location testUri aR) (Just "MyData")
            b = SymbolInformation "B" SkConstructor Nothing (Location testUri bR) (Just "MyData")

        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"
        Right symbs <- getDocumentSymbols doc

        let foo = SymbolInformation "foo" SkFunction Nothing (Location testUri fooR) (Just "Symbols")
            bar = SymbolInformation "bar" SkFunction Nothing (Location testUri barR) (Just "foo")
            dog = SymbolInformation "dog" SkVariable Nothing (Location testUri dogR) (Just "bar")
            cat = SymbolInformation "cat" SkVariable Nothing (Location testUri catR) (Just "bar")

        -- 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"
        Right symbs <- getDocumentSymbols doc

        let testPattern = SymbolInformation "TestPattern"
                SkFunction Nothing (Location testUri testPatternR) (Just "Symbols")

        liftIO $ testPattern `elem` symbs @? "Contains symbols"

    , testCase "provides imports" $ runSession hlsCommand oldCaps "test/testdata" $ do
        doc@(TextDocumentIdentifier testUri) <- openDoc "Symbols.hs" "haskell"
        Right symbs <- getDocumentSymbols doc

        let imports = SymbolInformation "imports" SkModule Nothing (Location testUri importsR) (Just "Symbols")
            importDataMaybe = SymbolInformation "import Data.Maybe" SkModule Nothing (Location testUri importDataMaybeR) (Just "imports")

        liftIO $ [imports, importDataMaybe] `isInfixOf` symbs @? "Contains symbol"
    ]

oldCaps :: ClientCapabilities
oldCaps = capsForVersion (LSPVersion 3 9)

fromList :: List a -> [a]
fromList (List a) = a

-- 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)