{-# LANGUAGE DataKinds             #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE GADTs                 #-}
{-# LANGUAGE LambdaCase            #-}
{-# LANGUAGE OverloadedStrings     #-}
{-# LANGUAGE ViewPatterns          #-}
module Progress (tests) where

import           Control.Exception                  (throw)
import           Control.Lens                       hiding ((.=))
import           Data.Aeson                         (decode, encode)
import           Data.Functor                       (void)
import           Data.List                          (delete)
import           Data.Maybe                         (fromJust)
import           Data.Text                          (Text, pack)
import           Ide.Types
import           Language.LSP.Protocol.Capabilities
import qualified Language.LSP.Protocol.Lens         as L
import           Test.Hls
import           Test.Hls.Command
import           Test.Hls.Flags


tests :: TestTree
tests =
    testGroup
        "window/workDoneProgress"
        [ testCase "sends indefinite progress notifications" $
            runSession hlsLspCommand progressCaps "test/testdata/diagnostics" $ do
                let path = "Foo.hs"
                _ <- openDoc path "haskell"
                expectProgressMessages [pack ("Setting up diagnostics (for " ++ path ++ ")"), "Processing", "Indexing"] []
        , requiresEvalPlugin $ testCase "eval plugin sends progress reports" $
            runSession hlsLspCommand progressCaps "plugins/hls-eval-plugin/test/testdata" $ do
              doc <- openDoc "T1.hs" "haskell"
              lspId <- sendRequest SMethod_TextDocumentCodeLens (CodeLensParams Nothing Nothing doc)

              (codeLensResponse, activeProgressTokens) <- expectProgressMessagesTill
                (responseForId SMethod_TextDocumentCodeLens lspId)
                ["Setting up testdata (for T1.hs)", "Processing", "Indexing"]
                []

              -- this is a test so exceptions result in fails
              let response = getMessageResult codeLensResponse
              case response of
                  InL [evalLens] -> do
                      let command = evalLens ^?! L.command . _Just

                      _ <- sendRequest SMethod_WorkspaceExecuteCommand $
                          ExecuteCommandParams
                          Nothing
                          (command ^. L.command)
                          (decode $ encode $ fromJust $ command ^. L.arguments)

                      expectProgressMessages ["Evaluating"] activeProgressTokens
                  _ -> error $ "Unexpected response result: " ++ show response
        , requiresOrmoluPlugin $ testCase "ormolu plugin sends progress notifications" $ do
            runSessionWithConfig (def { ignoreConfigurationRequests = False }) hlsLspCommand progressCaps "test/testdata/format" $ do
                void configurationRequest
                setHlsConfig (formatLspConfig "ormolu")
                doc <- openDoc "Format.hs" "haskell"
                expectProgressMessages ["Setting up testdata (for Format.hs)", "Processing", "Indexing"] []
                _ <- sendRequest SMethod_TextDocumentFormatting $ DocumentFormattingParams Nothing doc (FormattingOptions 2 True Nothing Nothing Nothing)
                expectProgressMessages ["Formatting Format.hs"] []
        , requiresFourmoluPlugin $ testCase "fourmolu plugin sends progress notifications" $ do
            runSessionWithConfig (def { ignoreConfigurationRequests = False }) hlsLspCommand progressCaps "test/testdata/format" $ do
                void configurationRequest
                setHlsConfig (formatLspConfig "fourmolu")
                doc <- openDoc "Format.hs" "haskell"
                expectProgressMessages ["Setting up testdata (for Format.hs)", "Processing", "Indexing"] []
                _ <- sendRequest SMethod_TextDocumentFormatting $ DocumentFormattingParams Nothing doc (FormattingOptions 2 True Nothing Nothing Nothing)
                expectProgressMessages ["Formatting Format.hs"] []
        ]

formatLspConfig :: Text -> Config
formatLspConfig provider = def { formattingProvider = provider }

progressCaps :: ClientCapabilities
progressCaps = fullCaps{_window = Just (WindowClientCapabilities (Just True) Nothing Nothing)}

data ProgressMessage
  = ProgressCreate WorkDoneProgressCreateParams
  | ProgressBegin ProgressToken WorkDoneProgressBegin
  | ProgressReport ProgressToken WorkDoneProgressReport
  | ProgressEnd ProgressToken WorkDoneProgressEnd

data InterestingMessage a
  = InterestingMessage a
  | ProgressMessage ProgressMessage

progressMessage :: Session ProgressMessage
progressMessage =
  progressCreate <|> progressBegin <|> progressReport <|> progressEnd
  where
    progressCreate = ProgressCreate . view L.params <$> message SMethod_WindowWorkDoneProgressCreate
    progressBegin :: Session ProgressMessage
    progressBegin = satisfyMaybe (\case
      FromServerMess  SMethod_Progress  (TNotificationMessage _ _ (ProgressParams t (preview _workDoneProgressBegin -> Just params))) ->
        Just (ProgressBegin t params)
      _ -> Nothing)
    progressReport :: Session ProgressMessage
    progressReport = satisfyMaybe (\case
      FromServerMess  SMethod_Progress  (TNotificationMessage _ _ (ProgressParams t (preview _workDoneProgressReport -> Just params))) ->
             Just (ProgressReport t params)
      _ -> Nothing)
    progressEnd :: Session ProgressMessage
    progressEnd = satisfyMaybe (\case
      FromServerMess  SMethod_Progress  (TNotificationMessage _ _ (ProgressParams t (preview _workDoneProgressEnd -> Just params)))
         -> Just (ProgressEnd t params)
      _ -> Nothing)

interestingMessage :: Session a -> Session (InterestingMessage a)
interestingMessage theMessage =
  fmap InterestingMessage theMessage <|> fmap ProgressMessage progressMessage

expectProgressMessagesTill :: Session a -> [Text] -> [ProgressToken] -> Session (a, [ProgressToken])
expectProgressMessagesTill stopMessage expectedTitles activeProgressTokens = do
  message <- skipManyTill anyMessage (interestingMessage stopMessage)
  case message of
    InterestingMessage a -> do
      liftIO $ null expectedTitles @? "Expected titles not empty " <> show expectedTitles
      pure (a, activeProgressTokens)
    ProgressMessage progressMessage ->
      updateExpectProgressStateAndRecurseWith
        (expectProgressMessagesTill stopMessage)
        progressMessage
        expectedTitles
        activeProgressTokens

{- | Test that the server is correctly producing a sequence of progress related
 messages. Each create must be pair with a corresponding begin and end,
 optionally with some progress in between. Tokens must match. The begin
 messages have titles describing the work that is in-progress, we check that
 the titles we see are those we expect.
-}
expectProgressMessages :: [Text] -> [ProgressToken] -> Session ()
expectProgressMessages [] [] = pure ()
expectProgressMessages expectedTitles activeProgressTokens = do
  message <- skipManyTill anyMessage progressMessage
  updateExpectProgressStateAndRecurseWith expectProgressMessages message expectedTitles activeProgressTokens

updateExpectProgressStateAndRecurseWith :: ([Text] -> [ProgressToken] -> Session a)
                                        -> ProgressMessage
                                        -> [Text]
                                        -> [ProgressToken]
                                        -> Session a
updateExpectProgressStateAndRecurseWith f progressMessage expectedTitles activeProgressTokens = do
  case progressMessage of
    ProgressCreate params -> do
      f expectedTitles ((params ^. L.token): activeProgressTokens)
    ProgressBegin token params -> do
      liftIO $ token `expectedIn` activeProgressTokens
      f (delete (params ^. L.title) expectedTitles) activeProgressTokens
    ProgressReport token _ -> do
      liftIO $ token `expectedIn` activeProgressTokens
      f expectedTitles activeProgressTokens
    ProgressEnd token _ -> do
      liftIO $ token `expectedIn` activeProgressTokens
      f expectedTitles (delete token activeProgressTokens)


expectedIn :: (Foldable t, Eq a, Show a) => a -> t a -> Assertion
expectedIn a as = a `elem` as @? "Unexpected " ++ show a

getMessageResult :: TResponseMessage m -> MessageResult m
getMessageResult rsp =
  case rsp ^. L.result of
    Right x -> x
    Left err -> throw $ UnexpectedResponseError (SomeLspId $ fromJust $ rsp ^. L.id) err