{-# LANGUAGE DataKinds             #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE GADTs                 #-}
{-# LANGUAGE LambdaCase            #-}
{-# LANGUAGE OverloadedStrings     #-}
{-# LANGUAGE PolyKinds             #-}

module Progress (tests) where

import           Control.Exception               (throw)
import           Control.Lens                    hiding ((.=))
import           Data.Aeson                      (Value, decode, encode, object,
                                                  (.=))
import           Data.List                       (delete)
import           Data.Maybe                      (fromJust)
import           Data.Text                       (Text, pack)
import qualified Language.LSP.Types              as LSP
import           Language.LSP.Types.Capabilities
import qualified Language.LSP.Types.Lens         as L
import           System.FilePath                 ((</>))
import           Test.Hls
import           Test.Hls.Command
import           Test.Hls.Flags


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

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

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

                      _ <- sendRequest SWorkspaceExecuteCommand $
                          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
            runSession hlsCommand progressCaps "test/testdata/format" $ do
                sendConfigurationChanged (formatLspConfig "ormolu")
                doc <- openDoc "Format.hs" "haskell"
                expectProgressMessages ["Setting up testdata (for Format.hs)", "Processing", "Indexing"] []
                _ <- sendRequest STextDocumentFormatting $ DocumentFormattingParams Nothing doc (FormattingOptions 2 True Nothing Nothing Nothing)
                expectProgressMessages ["Formatting Format.hs"] []
        , requiresFourmoluPlugin $ testCase "fourmolu plugin sends progress notifications" $ do
            runSession hlsCommand progressCaps "test/testdata/format" $ do
                sendConfigurationChanged (formatLspConfig "fourmolu")
                doc <- openDoc "Format.hs" "haskell"
                expectProgressMessages ["Setting up testdata (for Format.hs)", "Processing", "Indexing"] []
                _ <- sendRequest STextDocumentFormatting $ DocumentFormattingParams Nothing doc (FormattingOptions 2 True Nothing Nothing Nothing)
                expectProgressMessages ["Formatting Format.hs"] []
        ]

formatLspConfig :: Value -> Value
formatLspConfig provider = object ["haskell" .= object ["formattingProvider" .= (provider :: Value)]]

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

data ProgressMessage
  = ProgressCreate WorkDoneProgressCreateParams
  | ProgressBegin (ProgressParams WorkDoneProgressBeginParams)
  | ProgressReport (ProgressParams WorkDoneProgressReportParams)
  | ProgressEnd (ProgressParams WorkDoneProgressEndParams)

data InterestingMessage a
  = InterestingMessage a
  | ProgressMessage ProgressMessage

progressMessage :: Session ProgressMessage
progressMessage =
  progressCreate <|> progressBegin <|> progressReport <|> progressEnd
  where
    progressCreate = ProgressCreate . view L.params <$> message SWindowWorkDoneProgressCreate
    progressBegin = ProgressBegin <$> satisfyMaybe (\case
      FromServerMess SProgress (NotificationMessage _ _ (ProgressParams t (Begin x))) -> Just (ProgressParams t x)
      _ -> Nothing)
    progressReport = ProgressReport <$> satisfyMaybe (\case
      FromServerMess SProgress (NotificationMessage _ _ (ProgressParams t (Report x))) -> Just (ProgressParams t x)
      _ -> Nothing)
    progressEnd = ProgressEnd <$> satisfyMaybe (\case
      FromServerMess SProgress (NotificationMessage _ _ (ProgressParams t (End x))) -> Just (ProgressParams t x)
      _ -> 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 (getToken params : activeProgressTokens)
    ProgressBegin params -> do
      liftIO $ getToken params `expectedIn` activeProgressTokens
      f (delete (getTitle params) expectedTitles) activeProgressTokens
    ProgressReport params -> do
      liftIO $ getToken params `expectedIn` activeProgressTokens
      f expectedTitles activeProgressTokens
    ProgressEnd params -> do
      liftIO $ getToken params `expectedIn` activeProgressTokens
      f expectedTitles (delete (getToken params) activeProgressTokens)

getTitle :: (L.HasValue s a1, L.HasTitle a1 a2) => s -> a2
getTitle msg = msg ^. L.value . L.title

getToken :: L.HasToken s a => s -> a
getToken msg = msg ^. L.token

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

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