{-# LANGUAGE DataKinds           #-}
{-# LANGUAGE ExplicitNamespaces  #-}
{-# LANGUAGE FlexibleInstances   #-}
{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE RankNTypes          #-}
{-# LANGUAGE ScopedTypeVariables #-}

import           Control.Lens                       ((^?))
import           Control.Monad.IO.Class             (liftIO)
import           Data.Aeson                         (KeyValue (..), Value (..),
                                                     object)
import           Data.Default
import           Data.Functor                       (void)
import           Data.Map                           as Map hiding (map)
import           Data.String                        (fromString)
import           Data.Text                          hiding (length, map,
                                                     unlines)
import qualified Data.Text                          as Text
import qualified Data.Text.Utf16.Rope               as Rope
import           Development.IDE.Plugin.Test        (WaitForIdeRuleResult (..))
import           Development.IDE.Test               (waitForBuildQueue)
import           Ide.Plugin.SemanticTokens
import           Ide.Plugin.SemanticTokens.Mappings
import           Ide.Plugin.SemanticTokens.Types
import           Ide.Types
import           Language.LSP.Protocol.Types        (SemanticTokenTypes (..),
                                                     _L)
import           Language.LSP.Test                  (Session (..),
                                                     SessionConfig (ignoreConfigurationRequests),
                                                     openDoc)
import qualified Language.LSP.Test                  as Test
import           Language.LSP.VFS                   (VirtualFile (..))
import           System.FilePath
import qualified Test.Hls                           as Test
import           Test.Hls                           (PluginTestDescriptor,
                                                     TestName, TestTree,
                                                     TextDocumentIdentifier,
                                                     defaultTestRunner,
                                                     documentContents, fullCaps,
                                                     goldenGitDiff,
                                                     mkPluginTestDescriptor,
                                                     pluginTestRecorder,
                                                     runSessionWithServerInTmpDir,
                                                     runSessionWithServerInTmpDir',
                                                     testCase, testGroup,
                                                     waitForAction, (@?=))
import qualified Test.Hls.FileSystem                as FS
import           Test.Hls.FileSystem                (file, text)

testDataDir :: FilePath
testDataDir = "test" </> "testdata"

mkFs :: [FS.FileTree] -> FS.VirtualFileTree
mkFs = FS.mkVirtualFileTree testDataDir

semanticTokensPlugin :: Test.Hls.PluginTestDescriptor SemanticLog
semanticTokensPlugin = Test.Hls.mkPluginTestDescriptor enabledSemanticDescriptor "SemanticTokens"
  where
    enabledSemanticDescriptor recorder plId =
      let semanticDescriptor = Ide.Plugin.SemanticTokens.descriptor recorder plId
       in semanticDescriptor
            { pluginConfigDescriptor =
                (pluginConfigDescriptor semanticDescriptor)
                  { configInitialGenericConfig =
                      (configInitialGenericConfig (pluginConfigDescriptor semanticDescriptor))
                        { plcGlobalOn = True
                        }
                  }
            }

goldenWithHaskellAndCapsOutPut config plugin title tree path desc act =
  goldenGitDiff title (FS.vftOriginalRoot tree </> path <.> desc) $
    runSessionWithServerInTmpDir config plugin tree $
      fromString <$> do
        doc <- openDoc (path <.> "hs") "haskell"
        void waitForBuildQueue
        act doc

goldenWithSemanticTokensWithDefaultConfig :: TestName -> FilePath -> TestTree
goldenWithSemanticTokensWithDefaultConfig title path =
  goldenWithHaskellAndCapsOutPut
    def
    semanticTokensPlugin
    title
    (mkFs $ FS.directProject (path <.> "hs"))
    path
    "expected"
    (docSemanticTokensString def)

docSemanticTokensString :: SemanticTokensConfig-> TextDocumentIdentifier -> Session String
docSemanticTokensString cf doc = do
  xs  <- map (lspTokenHsToken cf) <$> docLspSemanticTokensString doc
  return $ unlines . map show $ xs

docLspSemanticTokensString :: TextDocumentIdentifier -> Session [SemanticTokenOriginal Language.LSP.Protocol.Types.SemanticTokenTypes]
docLspSemanticTokensString doc = do
  res <- Test.getSemanticTokens doc
  textContent <- documentContents doc
  let vfs = VirtualFile 0 0 (Rope.fromText textContent)
  case res ^? Language.LSP.Protocol.Types._L of
    Just tokens -> do
      either (error . show) pure $ recoverLspSemanticTokens vfs tokens
    _noTokens -> error "No tokens found"

semanticTokensClassTests :: TestTree
semanticTokensClassTests =
  testGroup
    "type class"
    [ goldenWithSemanticTokensWithDefaultConfig "golden type class" "TClass",
      goldenWithSemanticTokensWithDefaultConfig "imported class method InstanceClassMethodBind" "TInstanceClassMethodBind",
      goldenWithSemanticTokensWithDefaultConfig "imported class method TInstanceClassMethodUse" "TInstanceClassMethodUse",
      goldenWithSemanticTokensWithDefaultConfig "imported deriving" "TClassImportedDeriving"
    ]

semanticTokensValuePatternTests :: TestTree
semanticTokensValuePatternTests =
  testGroup
    "value and patterns "
    [ goldenWithSemanticTokensWithDefaultConfig "value bind" "TValBind",
      goldenWithSemanticTokensWithDefaultConfig "pattern match" "TPatternMatch",
      goldenWithSemanticTokensWithDefaultConfig "pattern bind" "TPatternbind"
    ]

mkSemanticConfig :: Value -> Config
mkSemanticConfig setting = def{plugins = Map.insert "SemanticTokens" conf (plugins def)}
    where
      conf = def{plcConfig = (\(Object obj) -> obj) setting }

modifySemantic :: Value -> Session ()
modifySemantic setting = Test.setHlsConfig $ mkSemanticConfig setting


directFile :: FilePath -> Text -> [FS.FileTree]
directFile fp content =
  [ FS.directCradle [Text.pack fp]
  , file fp (text content)
  ]

semanticTokensConfigTest :: TestTree
semanticTokensConfigTest = testGroup "semantic token config test" [
        testCase "function to variable" $ do
            let content = Text.unlines ["module Hello where", "go _ = 1"]
            let fs = mkFs $ directFile "Hello.hs" content
            let funcVar = object ["functionToken" .= var]
                var :: String
                var = "variable"
            do
                recorder <- pluginTestRecorder
                Test.Hls.runSessionWithServerInTmpDir' (semanticTokensPlugin recorder)
                    (mkSemanticConfig funcVar)
                    def {ignoreConfigurationRequests = False}
                    fullCaps
                    fs $ do
                    -- modifySemantic funcVar
                    void waitForBuildQueue
                    doc <- openDoc "Hello.hs" "haskell"
                    void waitForBuildQueue
                    result1 <- docLspSemanticTokensString doc
                    liftIO $ unlines (map show result1) @?= "2:1-3 SemanticTokenTypes_Variable \"go\"\n"
    ]

semanticTokensTests :: TestTree
semanticTokensTests =
  testGroup
    "other semantic Token test"
    [ testCase "module import test" $ do
        let file1 = "TModuleA.hs"
        let file2 = "TModuleB.hs"
        let expect =
              [ SemanticTokenOriginal TVariable (Loc 5 1 2) "go",
                SemanticTokenOriginal TDataConstructor (Loc 5 6 4) "Game"
              ]
        Test.Hls.runSessionWithServerInTmpDir def semanticTokensPlugin (mkFs $ FS.directProjectMulti [file1, file2]) $ do
          doc1 <- openDoc file1 "haskell"
          doc2 <- openDoc file2 "haskell"
          _check1 <- waitForAction "TypeCheck" doc1
          check2 <- waitForAction "TypeCheck" doc2
          case check2 of
            Right (WaitForIdeRuleResult _) -> return ()
            Left _                         -> error "TypeCheck2 failed"

          textContent2 <- documentContents doc2
          let vfs = VirtualFile 0 0 (Rope.fromText textContent2)
          res2 <- Test.getSemanticTokens doc2
          case res2 ^? Language.LSP.Protocol.Types._L of
            Just tokens -> do
              either
                (error . show)
                (\xs -> liftIO $ xs @?= expect)
                $ recoverSemanticTokens def vfs tokens
              return ()
            _ -> error "No tokens found"
          liftIO $ 1 @?= 1,
      goldenWithSemanticTokensWithDefaultConfig "mixed constancy test result generated from one ghc version" "T1",
      goldenWithSemanticTokensWithDefaultConfig "pattern bind" "TPatternSynonym",
      goldenWithSemanticTokensWithDefaultConfig "type family" "TTypefamily",
      goldenWithSemanticTokensWithDefaultConfig "TUnicodeSyntax" "TUnicodeSyntax"
    ]

semanticTokensDataTypeTests :: TestTree
semanticTokensDataTypeTests =
  testGroup
    "get semantic Tokens"
    [ goldenWithSemanticTokensWithDefaultConfig "simple datatype" "TDataType",
      goldenWithSemanticTokensWithDefaultConfig "record" "TRecord",
      goldenWithSemanticTokensWithDefaultConfig "record With DuplicateRecordFields" "TRecordDuplicateRecordFields",
      goldenWithSemanticTokensWithDefaultConfig "datatype import" "TDatatypeImported",
      goldenWithSemanticTokensWithDefaultConfig "datatype family" "TDataFamily",
      goldenWithSemanticTokensWithDefaultConfig "GADT" "TGADT"
    ]

semanticTokensFunctionTests :: TestTree
semanticTokensFunctionTests =
  testGroup
    "get semantic of functions"
    [ goldenWithSemanticTokensWithDefaultConfig "functions" "TFunction",
      goldenWithSemanticTokensWithDefaultConfig "local functions" "TFunctionLocal",
      goldenWithSemanticTokensWithDefaultConfig "function in let binding" "TFunctionLet",
      goldenWithSemanticTokensWithDefaultConfig "negative case non-function with constraint" "TNoneFunctionWithConstraint"
    ]

main :: IO ()
main =
  defaultTestRunner $
    testGroup
      "Semantic tokens"
      [ semanticTokensTests,
        semanticTokensClassTests,
        semanticTokensDataTypeTests,
        semanticTokensValuePatternTests,
        semanticTokensFunctionTests,
        semanticTokensConfigTest
      ]