{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}

module Progress (tests) where

import Control.Applicative.Combinators
import Control.Lens hiding ((.=))
import Control.Monad.IO.Class
import Data.Aeson (Value, decode, encode, object, toJSON, (.=))
import Data.Default
import Data.List (delete)
import Data.Maybe (fromJust)
import Data.Text (Text, pack)
import Ide.Plugin.Config
import Language.Haskell.LSP.Test
import Language.Haskell.LSP.Types
import Language.Haskell.LSP.Types.Capabilities
import qualified Language.Haskell.LSP.Types.Lens as L
import System.FilePath ((</>))
import Test.Hls.Util
import Test.Tasty
import Test.Tasty.ExpectedFailure (ignoreTestBecause)
import Test.Tasty.HUnit

tests :: TestTree
tests =
    testGroup
        "window/workDoneProgress"
        [ testCase "sends indefinite progress notifications" $
            runSession hlsCommand progressCaps "test/testdata" $ do
                let path = "hlint" </> "ApplyRefact2.hs"
                _ <- openDoc path "haskell"
                expectProgressReports [pack ("Setting up hlint (for " ++ path ++ ")"), "Processing"]
        , testCase "eval plugin sends progress reports" $
            runSession hlsCommand progressCaps "plugins/hls-eval-plugin/test/testdata" $ do
                doc <- openDoc "T1.hs" "haskell"
                expectProgressReports ["Setting up testdata (for T1.hs)", "Processing"]
                [evalLens] <- getCodeLenses doc
                let cmd = evalLens ^?! L.command . _Just
                _ <- sendRequest WorkspaceExecuteCommand $ ExecuteCommandParams (cmd ^. L.command) (decode $ encode $ fromJust $ cmd ^. L.arguments) Nothing
                expectProgressReports ["Evaluating"]
        , testCase "ormolu plugin sends progress notifications" $ do
            runSession hlsCommand progressCaps "test/testdata/format" $ do
                sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams (formatLspConfig "ormolu"))
                doc <- openDoc "Format.hs" "haskell"
                expectProgressReports ["Setting up testdata (for Format.hs)", "Processing"]
                _ <- sendRequest TextDocumentFormatting $ DocumentFormattingParams doc (FormattingOptions 2 True) Nothing
                expectProgressReports ["Formatting Format.hs"]
        , testCase "fourmolu plugin sends progress notifications" $ do
            runSession hlsCommand progressCaps "test/testdata/format" $ do
                sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams (formatLspConfig "fourmolu"))
                doc <- openDoc "Format.hs" "haskell"
                expectProgressReports ["Setting up testdata (for Format.hs)", "Processing"]
                _ <- sendRequest TextDocumentFormatting $ DocumentFormattingParams doc (FormattingOptions 2 True) Nothing
                expectProgressReports ["Formatting Format.hs"]
        , ignoreTestBecause "no liquid Haskell support" $
            testCase "liquid haskell plugin sends progress notifications" $ do
                runSession hlsCommand progressCaps "test/testdata" $ do
                    doc <- openDoc "liquid/Evens.hs" "haskell"
                    let config = def{liquidOn = True, hlintOn = False}
                    sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams (toJSON config))
                    sendNotification TextDocumentDidSave (DidSaveTextDocumentParams doc)
                    expectProgressReports ["Running Liquid Haskell on Evens.hs"]
        ]

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

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

data CollectedProgressNotification
    = CreateM WorkDoneProgressCreateRequest
    | BeginM WorkDoneProgressBeginNotification
    | ProgressM WorkDoneProgressReportNotification
    | EndM WorkDoneProgressEndNotification

{- | 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.
-}
expectProgressReports :: [Text] -> Session ()
expectProgressReports = expectProgressReports' []
  where
    expectProgressReports' [] [] = return ()
    expectProgressReports' tokens expectedTitles =
        do
            skipManyTill anyMessage (create <|> begin <|> progress <|> end)
            >>= \case
                CreateM msg ->
                    expectProgressReports' (token msg : tokens) expectedTitles
                BeginM msg -> do
                    liftIO $ title msg `expectElem` expectedTitles
                    liftIO $ token msg `expectElem` tokens
                    expectProgressReports' tokens (delete (title msg) expectedTitles)
                ProgressM msg -> do
                    liftIO $ token msg `expectElem` tokens
                    expectProgressReports' tokens expectedTitles
                EndM msg -> do
                    liftIO $ token msg `expectElem` tokens
                    expectProgressReports' (delete (token msg) tokens) expectedTitles
    title msg = msg ^. L.params ^. L.value ^. L.title
    token msg = msg ^. L.params ^. L.token
    create = CreateM <$> message
    begin = BeginM <$> message
    progress = ProgressM <$> message
    end = EndM <$> message
    expectElem a as = a `elem` as @? "Unexpected " ++ show a