{-# LANGUAGE DataKinds                #-}
{-# LANGUAGE DisambiguateRecordFields #-}
{-# LANGUAGE OverloadedStrings        #-}

module Main (main) where

import           Control.Lens                ((^.))
import           Data.Aeson                  (KeyValue ((.=)))
import           Data.Functor                (void)
import qualified Data.Map                    as M
import           Data.Text                   (Text, pack)
import qualified Data.Text.IO                as TIO
import           Development.IDE.Test        (referenceReady)
import           Ide.Plugin.Config
import qualified Ide.Plugin.Rename           as Rename
import qualified Language.LSP.Protocol.Lens  as L
import           Language.LSP.Protocol.Types (Null (Null))
import           System.FilePath
import           Test.Hls

main :: IO ()
main = defaultTestRunner tests

renamePlugin :: PluginTestDescriptor Rename.Log
renamePlugin = mkPluginTestDescriptor Rename.descriptor "rename"

tests :: TestTree
tests = testGroup "Rename"
    [ prepareRenameTests
    , renameTests
    , moduleNameTests
    , crossModuleTests
    ]

prepareRenameTests :: TestTree
prepareRenameTests = testGroup "PrepareRename"
    [ testCase "Module name (not yet renameable)" $ runRenameSession "" $ do
        doc <- openDoc "PrepareRename.hs" "haskell"
        void waitForBuildQueue
        result <- prepareRename doc (Position 0 9)
        liftIO $ result @?= InR Null

    , testCase "Function name" $ runRenameSession "" $ do
        doc <- openDoc "PrepareRename.hs" "haskell"
        void waitForBuildQueue
        result <- prepareRename doc (Position 8 1)
        liftIO $ result @?=
            InL (PrepareRenameResult (InL (Range (Position 8 0) (Position 8 3))))

    , testCase "Imported function name" $ runRenameSession "" $ do
        doc <- openDoc "PrepareRename.hs" "haskell"
        void waitForBuildQueue
        result <- prepareRename doc (Position 10 16)
        liftIO $ result @?=
            InL (PrepareRenameResult (InL (Range (Position 10 14) (Position 10 19))))

    , testCase "Non-renameable position" $ runRenameSession "" $ do
        doc <- openDoc "PrepareRename.hs" "haskell"
        void waitForBuildQueue
        result <- prepareRename doc (Position 6 23)
        liftIO $ result @?= InR Null

    , testCase "Operator" $ runRenameSession "" $ do
        doc <- openDoc "PrepareRename.hs" "haskell"
        void waitForBuildQueue
        result <- prepareRename doc (Position 10 7)
        liftIO $ result @?=
            InL (PrepareRenameResult (InL (Range (Position 10 6) (Position 10 9))))

    , testCase "Built-in operator" $ runRenameSession "" $ do
        doc <- openDoc "PrepareRename.hs" "haskell"
        void waitForBuildQueue
        result <- prepareRename doc (Position 13 7)
        liftIO $ result @?=
            InL (PrepareRenameResult (InL (Range (Position 13 7) (Position 13 8))))
    ]

renameTests :: TestTree
renameTests = testGroup "Identifier"
    [ goldenWithRename "Data constructor" "DataConstructor" $ \doc ->
        rename doc (Position 0 15) "Op"
    , goldenWithRename "Data constructor with fields" "DataConstructorWithFields" $ \doc ->
        rename doc (Position 1 13) "FooRenamed"
    , knownBrokenForGhcVersions [GHC96, GHC98] "renaming Constructor{..} with RecordWildcard removes .." $
        goldenWithRename "Data constructor with fields" "DataConstructorWithFieldsRecordWildcards" $ \doc ->
          rename doc (Position 1 13) "FooRenamed"
    , goldenWithRename "Exported function" "ExportedFunction" $ \doc ->
        rename doc (Position 2 1) "quux"
    , goldenWithRename "Field Puns" "FieldPuns" $ \doc ->
        rename doc (Position 7 13) "bleh"
    , goldenWithRename "Function argument" "FunctionArgument" $ \doc ->
        rename doc (Position 3 4) "y"
    , goldenWithRename "Function name" "FunctionName" $ \doc ->
        rename doc (Position 3 1) "baz"
    , goldenWithRename "GADT" "Gadt" $ \doc ->
        rename doc (Position 6 37) "Expr"
    , goldenWithRename "Hidden function" "HiddenFunction" $ \doc ->
        rename doc (Position 0 32) "quux"
    , goldenWithRename "Imported function" "ImportedFunction" $ \doc ->
        rename doc (Position 3 8) "baz"
    , goldenWithRename "Import hiding" "ImportHiding" $ \doc ->
        rename doc (Position 0 22) "hiddenFoo"
    , goldenWithRename "Indirect Puns" "IndirectPuns" $ \doc ->
        rename doc (Position 4 23) "blah"
    , goldenWithRename "Let expression" "LetExpression" $ \doc ->
        rename doc (Position 5 11) "foobar"
    , goldenWithRename "Qualified as" "QualifiedAs" $ \doc ->
        rename doc (Position 3 10) "baz"
    , goldenWithRename "Qualified shadowing" "QualifiedShadowing" $ \doc ->
        rename doc (Position 3 12) "foobar"
    , goldenWithRename "Qualified function" "QualifiedFunction" $ \doc ->
        rename doc (Position 3 12) "baz"
    , goldenWithRename "Realigns do block indentation" "RealignDo" $ \doc ->
        rename doc (Position 0 2) "fooBarQuux"
    , goldenWithRename "Record field" "RecordField" $ \doc ->
        rename doc (Position 6 9) "number"
    , goldenWithRename "Shadowed name" "ShadowedName" $ \doc ->
        rename doc (Position 1 1) "baz"
    , goldenWithRename "Typeclass" "Typeclass" $ \doc ->
        rename doc (Position 8 15) "Equal"
    , goldenWithRename "Type constructor" "TypeConstructor" $ \doc ->
        rename doc (Position 2 17) "BinaryTree"
    , goldenWithRename "Type variable" "TypeVariable" $ \doc ->
        rename doc (Position 0 13) "b"
    , goldenWithRename "Rename within comment" "Comment" $ \doc -> do
        let expectedError = TResponseError
                (InR ErrorCodes_InvalidParams)
                "rename: Invalid Params: No symbol to rename at given position"
                Nothing
        renameExpectError expectedError doc (Position 0 10) "ImpossibleRename"

    , testCase "fails when module does not compile" $ runRenameSession "" $ do
        doc <- openDoc "FunctionArgument.hs" "haskell"
        expectNoMoreDiagnostics 3 doc "typecheck"

        -- Update the document so it doesn't compile
        let change = TextDocumentContentChangeEvent $ InL TextDocumentContentChangePartial
              { _range = Range (Position 2 13) (Position 2 17)
              , _rangeLength = Nothing
              , _text = "A"
              }
        changeDoc doc [change]
        diags@(tcDiag : _) <- waitForDiagnosticsFrom doc

        -- Make sure there's a typecheck error
        liftIO $ do
          length diags @?= 1
          tcDiag ^. L.range @?= Range (Position 2 13) (Position 2 14)
          tcDiag ^. L.severity @?= Just DiagnosticSeverity_Error
          tcDiag ^. L.source @?= Just "typecheck"

        -- Make sure renaming fails
        renameErr <- expectRenameError doc (Position 3 0) "foo'"
        liftIO $ do
          renameErr ^. L.code @?= InL LSPErrorCodes_RequestFailed
          renameErr ^. L.message @?= "rename: Rule Failed: GetHieAst"

        -- Update the document so it compiles
        let change' = TextDocumentContentChangeEvent $  InL TextDocumentContentChangePartial
              { _range = Range (Position 2 13) (Position 2 14)
              , _rangeLength = Nothing
              , _text = "Int"
              }
        changeDoc doc [change']
        expectNoMoreDiagnostics 3 doc "typecheck"

        -- Make sure renaming succeeds
        rename doc (Position 3 0) "foo'"
    ]

crossModuleTests :: TestTree
crossModuleTests =
    testGroup
        "CrossModule"
        [ testCase "Term used in two modules" $ runRenameSession "" $ do
            defDoc <- openDoc "CrossModuleDefinition.hs" "haskell"
            useDoc <- openDoc "CrossModuleUsage.hs" "haskell"
            void $ skipManyTill anyMessage $ referenceReady (((==) "CrossModuleUsage.hs") . takeFileName)
            rename defDoc (Position 3 0) "succInt"
            assertGolden "CrossModuleDefinition" defDoc
            assertGolden "CrossModuleUsage" useDoc
        ]
  where
    assertGolden path doc = do
        actual <- documentContents doc
        expected <- liftIO $ TIO.readFile (testDataDir </> path <.> "expected" <.> "hs")
        liftIO $ assertEqual path expected actual

moduleNameTests :: TestTree
moduleNameTests =
  testGroup "ModuleName"
  [ goldenWithModuleName "Add module header to empty module" "TEmptyModule" $ \doc -> do
      [CodeLens { _command = Just c }] <- getCodeLenses doc
      executeCommand c
      void $ skipManyTill anyMessage (message SMethod_WorkspaceApplyEdit)

  , goldenWithModuleName "Fix wrong module name" "TWrongModuleName" $ \doc -> do
      [CodeLens { _command = Just c }] <- getCodeLenses doc
      executeCommand c
      void $ skipManyTill anyMessage (message SMethod_WorkspaceApplyEdit)

  , goldenWithModuleName "Must infer module name as Main, if the file name starts with a lowercase" "mainlike" $ \doc -> do
      [CodeLens { _command = Just c }] <- getCodeLenses doc
      executeCommand c
      void $ skipManyTill anyMessage (message SMethod_WorkspaceApplyEdit)

  , goldenWithModuleName "Fix wrong module name in nested directory" "subdir/TWrongModuleName" $ \doc -> do
      [CodeLens { _command = Just c }] <- getCodeLenses doc
      executeCommand c
      void $ skipManyTill anyMessage (message SMethod_WorkspaceApplyEdit)
  , testCase "Should not show code lens if the module name is correct" $
      runSessionWithServer def renamePlugin modNameTestDataDir $ do
        doc <- openDoc "CorrectName.hs" "haskell"
        lenses <- getCodeLenses doc
        liftIO $ lenses @?= []
        closeDoc doc
  -- https://github.com/haskell/haskell-language-server/issues/3047
  , goldenWithModuleName "Fix#3047" "canonicalize/Lib/A" $ \doc -> do
      [CodeLens { _command = Just c }] <- getCodeLenses doc
      executeCommand c
      void $ skipManyTill anyMessage (message SMethod_WorkspaceApplyEdit)
  , testCase "Keep stale lens even if parse failed" $ do
      runSessionWithServer def renamePlugin modNameTestDataDir $ do
        doc <- openDoc "Stale.hs" "haskell"
        oldLens <- getCodeLenses doc
        let edit = TextEdit (mkRange 1 0 1 0) "f ="
        _ <- applyEdit doc edit
        newLens <- getCodeLenses doc
        liftIO $ newLens @?= oldLens
        closeDoc doc
  ]

goldenWithModuleName :: TestName -> FilePath -> (TextDocumentIdentifier -> Session ()) -> TestTree
goldenWithModuleName title path = goldenWithHaskellDoc def renamePlugin title modNameTestDataDir path "expected" "hs"

modNameTestDataDir :: FilePath
modNameTestDataDir = testDataDir </> "mod_name"

goldenWithRename :: TestName-> FilePath -> (TextDocumentIdentifier -> Session ()) -> TestTree
goldenWithRename title path act =
    goldenWithHaskellDoc (def { plugins = M.fromList [("rename", def { plcConfig = "crossModule" .= True })] })
       renamePlugin title testDataDir path "expected" "hs" act

-- NOTE: This should eventually be moved upstream to lsp-test (see
-- https://github.com/haskell/lsp/issues/636).
prepareRename :: TextDocumentIdentifier -> Position -> Session (PrepareRenameResult |? Null)
prepareRename doc pos = do
  let params = PrepareRenameParams doc pos Nothing
  rsp <- request SMethod_TextDocumentPrepareRename params
  case rsp ^. L.result of
    Left rspError -> liftIO $ assertFailure $ "prepareRename failed: " <> show rspError
    Right rspResult -> pure rspResult

renameExpectError :: TResponseError Method_TextDocumentRename -> TextDocumentIdentifier -> Position -> Text -> Session ()
renameExpectError expectedError doc pos newName = do
  let params = RenameParams Nothing doc pos newName
  rsp <- request SMethod_TextDocumentRename params
  case rsp ^. L.result of
    Right _ -> liftIO $ assertFailure $ "Was expecting " <> show expectedError <> ", got success"
    Left actualError -> liftIO $ assertEqual "ResponseError" expectedError actualError

testDataDir :: FilePath
testDataDir = "plugins" </> "hls-rename-plugin" </> "test" </> "testdata"

-- | Attempts to renames the term at the specified position, expecting a failure
expectRenameError ::
  TextDocumentIdentifier ->
  Position ->
  String ->
  Session (TResponseError Method_TextDocumentRename)
expectRenameError doc pos newName = do
  let params = RenameParams Nothing doc pos (pack newName)
  rsp <- request SMethod_TextDocumentRename params
  case rsp ^. L.result of
    Left err -> pure err
    Right _ -> liftIO $ assertFailure $
      "Got unexpected successful rename response for " <> show (doc ^. L.uri)

runRenameSession :: FilePath -> Session a -> IO a
runRenameSession subdir = failIfSessionTimeout
  .  runSessionWithTestConfig def
  { testDirLocation = Left $ testDataDir </> subdir
  , testPluginDescriptor = renamePlugin
  , testConfigCaps = codeActionNoResolveCaps }
  . const
