{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Completion(tests) where

import Control.Monad.IO.Class
import Control.Lens hiding ((.=))
import Data.Aeson (object, (.=))
import Language.Haskell.LSP.Test
import Language.Haskell.LSP.Types
import Language.Haskell.LSP.Types.Lens hiding (applyEdit)
import Test.Hls.Util
import Test.Tasty
import Test.Tasty.ExpectedFailure (ignoreTestBecause)
import Test.Tasty.HUnit
import qualified Data.Text as T
import System.Time.Extra (sleep)

tests :: TestTree
tests = testGroup "completions" [
     testCase "works" $ runSession hlsCommand fullCaps "test/testdata/completion" $ do
         doc <- openDoc "Completion.hs" "haskell"

         let te = TextEdit (Range (Position 5 7) (Position 5 24)) "put"
         _ <- applyEdit doc te

         compls <- getCompletions doc (Position 5 9)
         let item = head $ filter ((== "putStrLn") . (^. label)) compls
         liftIO $ do
             item ^. label @?= "putStrLn"
             item ^. kind @?= Just CiFunction
             item ^. detail @?= Just ":: String -> IO ()"
             item ^. insertTextFormat @?= Just Snippet
             item ^. insertText @?= Just "putStrLn ${1:String}"

     , ignoreTestBecause "no support for itemCompletion/resolve requests"
       $ testCase "itemCompletion/resolve works" $ runSession hlsCommand fullCaps "test/testdata/completion" $ do
         doc <- openDoc "Completion.hs" "haskell"

         let te = TextEdit (Range (Position 5 7) (Position 5 24)) "put"
         _ <- applyEdit doc te

         compls <- getCompletions doc (Position 5 9)
         let item = head $ filter ((== "putStrLn") . (^. label)) compls
         resolvedRes <- request CompletionItemResolve item
         let Right (resolved :: CompletionItem) = resolvedRes ^. result
         liftIO $ print resolved
         liftIO $ do
             resolved ^. label @?= "putStrLn"
             resolved ^. kind @?= Just CiFunction
             resolved ^. detail @?= Just "String -> IO ()\nPrelude"
             resolved ^. insertTextFormat @?= Just Snippet
             resolved ^. insertText @?= Just "putStrLn ${1:String}"

     , testCase "completes imports" $ runSession hlsCommand fullCaps "test/testdata/completion" $ do
         doc <- openDoc "Completion.hs" "haskell"

         liftIO $ sleep 4

         let te = TextEdit (Range (Position 1 17) (Position 1 26)) "Data.M"
         _ <- applyEdit doc te

         compls <- getCompletions doc (Position 1 22)
         let item = head $ filter ((== "Maybe") . (^. label)) compls
         liftIO $ do
             item ^. label @?= "Maybe"
             item ^. detail @?= Just "Data.Maybe"
             item ^. kind @?= Just CiModule

     , testCase "completes qualified imports" $ runSession hlsCommand fullCaps "test/testdata/completion" $ do
         doc <- openDoc "Completion.hs" "haskell"

         liftIO $ sleep 4

         let te = TextEdit (Range (Position 2 17) (Position 1 25)) "Dat"
         _ <- applyEdit doc te

         compls <- getCompletions doc (Position 1 19)
         let item = head $ filter ((== "Data.List") . (^. label)) compls
         liftIO $ do
             item ^. label @?= "Data.List"
             item ^. detail @?= Just "Data.List"
             item ^. kind @?= Just CiModule

     , testCase "completes language extensions" $ runSession hlsCommand fullCaps "test/testdata/completion" $ do
         doc <- openDoc "Completion.hs" "haskell"

         liftIO $ sleep 4

         let te = TextEdit (Range (Position 0 24) (Position 0 31)) ""
         _ <- applyEdit doc te

         compls <- getCompletions doc (Position 0 24)
         let item = head $ filter ((== "OverloadedStrings") . (^. label)) compls
         liftIO $ do
             item ^. label @?= "OverloadedStrings"
             item ^. kind @?= Just CiKeyword

     , testCase "completes pragmas" $ runSession hlsCommand fullCaps "test/testdata/completion" $ do
         doc <- openDoc "Completion.hs" "haskell"

         liftIO $ sleep 4

         let te = TextEdit (Range (Position 0 4) (Position 0 34)) ""
         _ <- applyEdit doc te

         compls <- getCompletions doc (Position 0 4)
         let item = head $ filter ((== "LANGUAGE") . (^. label)) compls
         liftIO $ do
             item ^. label @?= "LANGUAGE"
             item ^. kind @?= Just CiKeyword
             item ^. insertTextFormat @?= Just Snippet
             item ^. insertText @?= Just "LANGUAGE ${1:extension} #-}"

     , testCase "completes pragmas no close" $ runSession hlsCommand fullCaps "test/testdata/completion" $ do
         doc <- openDoc "Completion.hs" "haskell"

         let te = TextEdit (Range (Position 0 4) (Position 0 24)) ""
         _ <- applyEdit doc te

         compls <- getCompletions doc (Position 0 4)
         let item = head $ filter ((== "LANGUAGE") . (^. label)) compls
         liftIO $ do
             item ^. label @?= "LANGUAGE"
             item ^. kind @?= Just CiKeyword
             item ^. insertTextFormat @?= Just Snippet
             item ^. insertText @?= Just "LANGUAGE ${1:extension}"

     , testCase "completes options pragma" $ runSession hlsCommand fullCaps "test/testdata/completion" $ do
         doc <- openDoc "Completion.hs" "haskell"

         liftIO $ sleep 4

         let te = TextEdit (Range (Position 0 4) (Position 0 34)) "OPTIONS"
         _ <- applyEdit doc te

         compls <- getCompletions doc (Position 0 4)
         let item = head $ filter ((== "OPTIONS_GHC") . (^. label)) compls
         liftIO $ do
             item ^. label @?= "OPTIONS_GHC"
             item ^. kind @?= Just CiKeyword
             item ^. insertTextFormat @?= Just Snippet
             item ^. insertText @?= Just "OPTIONS_GHC -${1:option} #-}"

     , testCase "completes ghc options pragma values" $ runSession hlsCommand fullCaps "test/testdata/completion" $ do
         doc <- openDoc "Completion.hs" "haskell"

         let te = TextEdit (Range (Position 0 0) (Position 0 0)) "{-# OPTIONS_GHC -Wno-red  #-}\n"
         _ <- applyEdit doc te

         compls <- getCompletions doc (Position 0 24)
         let item = head $ filter ((== "Wno-redundant-constraints") . (^. label)) compls
         liftIO $ do
             item ^. label @?= "Wno-redundant-constraints"
             item ^. kind @?= Just CiKeyword
             item ^. insertTextFormat @?= Nothing
             item ^. insertText @?= Nothing

     , testCase "completes with no prefix" $ runSession hlsCommand fullCaps "test/testdata/completion" $ do
         doc <- openDoc "Completion.hs" "haskell"

         compls <- getCompletions doc (Position 5 7)
         liftIO $ any ((== "!!") . (^. label)) compls @? ""

     -- See https://github.com/haskell/haskell-ide-engine/issues/903
     , testCase "strips compiler generated stuff from completions" $ runSession hlsCommand fullCaps "test/testdata/completion" $ do
         doc <- openDoc "DupRecFields.hs" "haskell"

         let te = TextEdit (Range (Position 5 0) (Position 5 2)) "acc"
         _ <- applyEdit doc te

         compls <- getCompletions doc (Position 5 4)
         let item = head $ filter (\c -> c^.label == "accessor") compls
         liftIO $ do
             item ^. label @?= "accessor"
             item ^. kind @?= Just CiFunction

     , testCase "have implicit foralls on basic polymorphic types" $ runSession hlsCommand fullCaps "test/testdata/completion" $ do
         doc <- openDoc "Completion.hs" "haskell"

         let te = TextEdit (Range (Position 5 7) (Position 5 9)) "id"
         _ <- applyEdit doc te
         compls <- getCompletions doc (Position 5 9)
         let item = head $ filter ((== "id") . (^. label)) compls
         liftIO $ do
             item ^. detail @?= Just ":: a -> a"

     , testCase "have implicit foralls with multiple type variables" $ runSession hlsCommand fullCaps "test/testdata/completion" $ do
         doc <- openDoc "Completion.hs" "haskell"

         let te = TextEdit (Range (Position 5 7) (Position 5 24)) "flip"
         _ <- applyEdit doc te
         compls <- getCompletions doc (Position 5 11)
         let item = head $ filter ((== "flip") . (^. label)) compls
         liftIO $
             item ^. detail @?= Just ":: (a -> b -> c) -> b -> a -> c"

     , contextTests
     , snippetTests
    ]

snippetTests :: TestTree
snippetTests = testGroup "snippets" [
    testCase "work for argumentless constructors" $ runSession hlsCommand fullCaps "test/testdata/completion" $ do
      doc <- openDoc "Completion.hs" "haskell"

      let te = TextEdit (Range (Position 5 7) (Position 5 24)) "Nothing"
      _ <- applyEdit doc te

      compls <- getCompletions doc (Position 5 14)
      let item = head $ filter ((== "Nothing") . (^. label)) compls
      liftIO $ do
          item ^. insertTextFormat @?= Just Snippet
          item ^. insertText @?= Just "Nothing "

    , testCase "work for polymorphic types" $ runSession hlsCommand fullCaps "test/testdata/completion" $ do
        doc <- openDoc "Completion.hs" "haskell"

        let te = TextEdit (Range (Position 5 7) (Position 5 24)) "fold"
        _ <- applyEdit doc te

        compls <- getCompletions doc (Position 5 11)
        let item = head $ filter ((== "foldl") . (^. label)) compls
        liftIO $ do
            item ^. label @?= "foldl"
            item ^. kind @?= Just CiFunction
            item ^. insertTextFormat @?= Just Snippet
            item ^. insertText @?= Just "foldl ${1:b -> a -> b} ${2:b} ${3:t a}"

    , testCase "work for complex types" $ runSession hlsCommand fullCaps "test/testdata/completion" $ do
        doc <- openDoc "Completion.hs" "haskell"

        let te = TextEdit (Range (Position 5 7) (Position 5 24)) "mapM"
        _ <- applyEdit doc te

        compls <- getCompletions doc (Position 5 11)
        let item = head $ filter ((== "mapM") . (^. label)) compls
        liftIO $ do
            item ^. label @?= "mapM"
            item ^. kind @?= Just CiFunction
            item ^. insertTextFormat @?= Just Snippet
            item ^. insertText @?= Just "mapM ${1:a -> m b} ${2:t a}"

    , testCase "work for infix functions" $ runSession hlsCommand fullCaps "test/testdata/completion" $ do
        doc <- openDoc "Completion.hs" "haskell"

        let te = TextEdit (Range (Position 5 7) (Position 5 24)) "even `filte"
        _ <- applyEdit doc te

        compls <- getCompletions doc (Position 5 18)
        let item = head $ filter ((== "filter") . (^. label)) compls
        liftIO $ do
            item ^. label @?= "filter"
            item ^. kind @?= Just CiFunction
            item ^. insertTextFormat @?= Just Snippet
            item ^. insertText @?= Just "filter ${1:a -> Bool} ${2:[a]}"

    , testCase "work for infix functions in backticks" $ runSession hlsCommand fullCaps "test/testdata/completion" $ do
        doc <- openDoc "Completion.hs" "haskell"

        let te = TextEdit (Range (Position 5 7) (Position 5 24)) "even `filte`"
        _ <- applyEdit doc te

        compls <- getCompletions doc (Position 5 18)
        let item = head $ filter ((== "filter") . (^. label)) compls
        liftIO $ do
            item ^. label @?= "filter"
            item ^. kind @?= Just CiFunction
            item ^. insertTextFormat @?= Just Snippet
            item ^. insertText @?= Just "filter ${1:a -> Bool} ${2:[a]}"

    , testCase "work for qualified infix functions" $ runSession hlsCommand fullCaps "test/testdata/completion" $ do
        doc <- openDoc "Completion.hs" "haskell"

        let te = TextEdit (Range (Position 5 7) (Position 5 24)) "\"\" `Data.List.interspe"
        _ <- applyEdit doc te

        compls <- getCompletions doc (Position 5 29)
        let item = head $ filter ((== "intersperse") . (^. label)) compls
        liftIO $ do
            item ^. label @?= "intersperse"
            item ^. kind @?= Just CiFunction
            item ^. insertTextFormat @?= Just Snippet
            item ^. insertText @?= Just "intersperse ${1:a} ${2:[a]}"

    , testCase "work for qualified infix functions in backticks" $ runSession hlsCommand fullCaps "test/testdata/completion" $ do
        doc <- openDoc "Completion.hs" "haskell"

        let te = TextEdit (Range (Position 5 7) (Position 5 24)) "\"\" `Data.List.interspe`"
        _ <- applyEdit doc te

        compls <- getCompletions doc (Position 5 29)
        let item = head $ filter ((== "intersperse") . (^. label)) compls
        liftIO $ do
            item ^. label @?= "intersperse"
            item ^. kind @?= Just CiFunction
            item ^. insertTextFormat @?= Just Snippet
            item ^. insertText @?= Just "intersperse ${1:a} ${2:[a]}"

    , ignoreTestBecause "ghcide does not support the completionSnippetsOn option" $
      testCase "respects lsp configuration" $ runSession hlsCommand fullCaps "test/testdata/completion" $ do
        doc <- openDoc "Completion.hs" "haskell"

        let config = object [ "haskell" .= (object ["completionSnippetsOn" .= False])]

        sendNotification WorkspaceDidChangeConfiguration
                        (DidChangeConfigurationParams config)

        checkNoSnippets doc

    , testCase "respects client capabilities" $ runSession hlsCommand noSnippetsCaps "test/testdata/completion" $ do
        doc <- openDoc "Completion.hs" "haskell"

        checkNoSnippets doc
    ]
    where
        checkNoSnippets doc = do
            let te = TextEdit (Range (Position 5 7) (Position 5 24)) "fold"
            _      <- applyEdit doc te

            compls <- getCompletions doc (Position 5 11)
            let item = head $ filter ((== "foldl") . (^. label)) compls
            liftIO $ do
                item ^. label @?= "foldl"
                item ^. kind @?= Just CiFunction
                item ^. insertTextFormat @?= Just PlainText
                item ^. insertText @?= Nothing

        noSnippetsCaps =
            (  textDocument
            .  _Just
            .  completion
            .  _Just
            .  completionItem
            .  _Just
            .  snippetSupport
            ?~ False
            )
            fullCaps

contextTests :: TestTree
contextTests = testGroup "contexts" [
    testCase "only provides type suggestions" $ runSession hlsCommand fullCaps "test/testdata/completion" $ do
      doc <- openDoc "Context.hs" "haskell"

      compls <- getCompletions doc (Position 2 17)
      liftIO $ do
        compls `shouldContainCompl` "Integer"
        compls `shouldNotContainCompl` "interact"

    , testCase "only provides value suggestions" $ runSession hlsCommand fullCaps "test/testdata/completion" $ do
      doc <- openDoc "Context.hs" "haskell"

      compls <- getCompletions doc (Position 3 9)
      liftIO $ do
        compls `shouldContainCompl` "abs"
        compls `shouldNotContainCompl` "Applicative"

    , testCase "completes qualified type suggestions" $ runSession hlsCommand fullCaps "test/testdata/completion" $ do
        doc <- openDoc "Context.hs" "haskell"

        compls <- getCompletions doc (Position 2 26)
        liftIO $ do
            compls `shouldNotContainCompl` "forkOn"
            compls `shouldContainCompl` "MVar"
            compls `shouldContainCompl` "Chan"
    ]

shouldContainCompl :: [CompletionItem] -> T.Text -> Assertion
compls `shouldContainCompl` x  =
    any ((== x) . (^. label)) compls
    @? "Should contain completion: " ++ show x

shouldNotContainCompl :: [CompletionItem] -> T.Text -> Assertion
compls `shouldNotContainCompl` x =
    all ((/= x) . (^. label)) compls
    @? "Should not contain completion: " ++ show x