{-# LANGUAGE DeriveAnyClass     #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE OverloadedStrings  #-}
module ResolveTests (tests) where

import           Config
import           Control.Lens
import           Data.Aeson
import qualified Data.Maybe                    as Maybe
import           Data.Text                     (Text)
import qualified Data.Text                     as T
import           GHC.Generics
import           Ide.Logger
import           Ide.Types                     (PluginDescriptor (..), PluginId,
                                                defaultPluginDescriptor,
                                                mkPluginHandler,
                                                mkResolveHandler)
import qualified Language.LSP.Protocol.Lens    as J
import qualified Language.LSP.Protocol.Lens    as JL
import           Language.LSP.Protocol.Message (SomeMethod (..))
import qualified Language.LSP.Protocol.Message as LSP
import           Language.LSP.Protocol.Types
import           Language.LSP.Test             hiding (resolveCompletion)
import           Test.Hls                      (IdeState, SMethod (..), liftIO,
                                                mkPluginTestDescriptor,
                                                someMethodToMethodString,
                                                waitForAllProgressDone)
import qualified Test.Hls.FileSystem           as FS
import           Test.Tasty
import           Test.Tasty.HUnit

tests :: TestTree
tests = testGroup "resolve"
  [ testGroup "with and without data" resolveRequests
  ]

removeData :: JL.HasData_ s (Maybe a) => s -> s
removeData param = param & JL.data_ .~ Nothing

simpleTestSession :: TestName -> Session () -> TestTree
simpleTestSession name act =
    testCase name $ runWithResolvePlugin (mkIdeTestFs [FS.directCradle ["A.hs"]]) (const act)

runWithResolvePlugin :: FS.VirtualFileTree -> (FilePath -> Session a) -> IO a
runWithResolvePlugin fs =
    testSessionWithPlugin fs
        (mkPluginTestDescriptor resolvePluginDescriptor "resolve-plugin")

data CompletionItemResolveData = CompletionItemResolveData
    { completionItemResolve_number :: Int
    }
    deriving stock (Show, Eq, Ord, Generic)
    deriving anyclass (ToJSON, FromJSON)

data CodeActionResolve = CodeActionResolve
    { codeActionResolve_number :: Int
    }
    deriving stock (Show, Eq, Ord, Generic)
    deriving anyclass (ToJSON, FromJSON)

data CodeLensResolve = CodeLensResolve
    { codeLensResolve_number :: Int
    }
    deriving stock (Show, Eq, Ord, Generic)
    deriving anyclass (ToJSON, FromJSON)

resolvePluginDescriptor :: Recorder (WithPriority Text) -> PluginId -> PluginDescriptor IdeState
resolvePluginDescriptor recorder pid = (defaultPluginDescriptor pid "Test Plugin for Resolve Requests")
  { pluginHandlers = mconcat
      [ mkResolveHandler LSP.SMethod_CompletionItemResolve $ \_ _ param _ CompletionItemResolveData{} -> pure param
      , mkPluginHandler LSP.SMethod_TextDocumentCompletion $ \_ _ _ -> do
          pure $ InL
            [ defCompletionItem "test item without data"
            , defCompletionItem "test item with data"
                & J.data_ .~ Just (toJSON $ CompletionItemResolveData 100)
            ]
      , mkResolveHandler LSP.SMethod_CodeActionResolve $ \_ _ param _ CodeActionResolve{} -> pure param
      , mkPluginHandler LSP.SMethod_TextDocumentCodeAction $ \_ _ _ -> do
          logWith recorder Debug "Why is the handler not called?"
          pure $ InL
            [ InR $ defCodeAction "test item without data"
            , InR $ defCodeAction "test item with data"
                & J.data_ .~ Just (toJSON $ CodeActionResolve 70)
            ]
      , mkResolveHandler LSP.SMethod_CodeLensResolve $ \_ _ param _ CodeLensResolve{} -> pure param
      , mkPluginHandler LSP.SMethod_TextDocumentCodeLens $ \_ _ _ -> do
          pure $ InL
            [ defCodeLens "test item without data"
            , defCodeLens "test item with data"
                & J.data_ .~ Just (toJSON $ CodeLensResolve 50)
            ]
      ]
  }

resolveRequests :: [TestTree]
resolveRequests =
  [ simpleTestSession "completion resolve" $ do
      doc <- createDoc "A.hs" "haskell" $ T.unlines
        [ "module A where"
        , "data Foo = Foo { foo :: Int }"
        , "bar = Foo 4"
        ]
      waitForAllProgressDone
      items <- getCompletions doc (Position 2 7)
      let resolveCompItems = filter (\i -> "test item" `T.isPrefixOf` (i ^. J.label)) items
      liftIO $ assertEqual "There must be exactly two results" 2 (length resolveCompItems)
      -- This must not throw an error.
      _ <- traverse (resolveCompletion . removeData) resolveCompItems
      pure ()
  , simpleTestSession "codeAction resolve" $ do
      doc <- createDoc "A.hs" "haskell" $ T.unlines
        [ "module A where"
        , "data Foo = Foo { foo :: Int }"
        , "bar = Foo 4"
        ]
      waitForAllProgressDone
      -- Cant use 'getAllCodeActions', as this lsp-test function queries the diagnostic
      -- locations and we don't have diagnostics in these tests.
      cas <- Maybe.mapMaybe (preview _R) <$> getCodeActions doc (Range (Position 0 0) (Position 1 0))
      let resolveCas = filter (\i -> "test item" `T.isPrefixOf` (i ^. J.title)) cas
      liftIO $ assertEqual "There must be exactly two results" 2 (length resolveCas)
      -- This must not throw an error.
      _ <- traverse (resolveCodeAction . removeData) resolveCas
      pure ()
  , simpleTestSession "codelens resolve" $ do
      doc <- createDoc "A.hs" "haskell" $ T.unlines
        [ "module A where"
        , "data Foo = Foo { foo :: Int }"
        , "bar = Foo 4"
        ]
      waitForAllProgressDone
      cd <- getCodeLenses doc
      let resolveCodeLenses = filter (\i -> case i ^. J.command of
            Just cmd -> "test item" `T.isPrefixOf` (cmd ^. J.title)
            Nothing  -> False
            ) cd
      liftIO $ assertEqual "There must be exactly two results" 2 (length resolveCodeLenses)
      -- This must not throw an error.
      _ <- traverse (resolveCodeLens . removeData) resolveCodeLenses
      pure ()
  ]

defCompletionItem :: T.Text -> CompletionItem
defCompletionItem lbl = CompletionItem
    { _label = lbl
    , _labelDetails = Nothing
    , _kind = Nothing
    , _tags = Nothing
    , _detail = Nothing
    , _documentation = Nothing
    , _deprecated = Nothing
    , _preselect = Nothing
    , _sortText = Nothing
    , _filterText = Nothing
    , _insertText = Just "insertion"
    , _insertTextFormat = Nothing
    , _insertTextMode = Nothing
    , _textEdit = Nothing
    , _textEditText = Nothing
    , _additionalTextEdits = Nothing
    , _commitCharacters = Nothing
    , _command = Nothing
    , _data_ = Nothing
    }

defCodeAction :: T.Text -> CodeAction
defCodeAction lbl = CodeAction
    { _title = lbl
    , _kind = Just CodeActionKind_Refactor
    , _diagnostics = Nothing
    , _isPreferred = Nothing
    , _disabled = Nothing
    , _edit = Nothing
    , _command = Just $ Command
        { _title = lbl
        , _command = lbl
        , _arguments = Nothing
        }
    , _data_ = Nothing
    }

defCodeLens :: T.Text -> CodeLens
defCodeLens lbl = CodeLens
    { _range = mkRange 0 0 1 0
    , _command = Just $ Command
        { _title = lbl
        , _command = lbl
        , _arguments = Nothing
        }
    , _data_ = Nothing
    }

-- TODO: expose this from lsp-test
resolveCompletion :: CompletionItem -> Session CompletionItem
resolveCompletion item = do
  rsp <- request SMethod_CompletionItemResolve item
  case rsp ^. JL.result of
      Left err -> liftIO $ assertFailure (someMethodToMethodString (SomeMethod SMethod_CompletionItemResolve) <> " failed with: " <> show err)
      Right x -> pure x