CompletionSpec.hs

{-# LANGUAGE OverloadedStrings #-}
module CompletionSpec where

import Control.Applicative.Combinators
import Control.Monad.IO.Class
import Control.Lens hiding ((.=))
import Data.Aeson
import Language.Haskell.LSP.Test
import Language.Haskell.LSP.Types
import Language.Haskell.LSP.Types.Lens hiding (applyEdit)
import Test.Hspec
import TestUtils

spec :: Spec
spec = describe "completions" $ do
  it "works" $ runSession hieCommand fullCaps "test/testdata/completion" $ do
    doc <- openDoc "Completion.hs" "haskell"
    _ <- skipManyTill loggingNotification (count 2 noDiagnostics)

    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 `shouldBe` "putStrLn"
      item ^. kind `shouldBe` Just CiFunction
      item ^. detail `shouldBe` Just "String -> IO ()\nPrelude"
      item ^. insertTextFormat `shouldBe` Just Snippet
      item ^. insertText `shouldBe` Just "putStrLn ${1:String}"

  it "completes imports" $ runSession hieCommand fullCaps "test/testdata/completion" $ do
    doc <- openDoc "Completion.hs" "haskell"
    _ <- skipManyTill loggingNotification (count 2 noDiagnostics)

    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 `shouldBe` "Maybe"
      item ^. detail `shouldBe` Just "Data.Maybe"
      item ^. kind `shouldBe` Just CiModule

  it "completes qualified imports" $ runSession hieCommand fullCaps "test/testdata/completion" $ do
    doc <- openDoc "Completion.hs" "haskell"
    _ <- skipManyTill loggingNotification (count 2 noDiagnostics)

    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 `shouldBe` "Data.List"
      item ^. detail `shouldBe` Just "Data.List"
      item ^. kind `shouldBe` Just CiModule

  it "completes language extensions" $ runSession hieCommand fullCaps "test/testdata/completion" $ do
    doc <- openDoc "Completion.hs" "haskell"
    _ <- skipManyTill loggingNotification (count 2 noDiagnostics)

    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 `shouldBe` "OverloadedStrings"
      item ^. kind `shouldBe` Just CiKeyword

  it "completes pragmas" $ runSession hieCommand fullCaps "test/testdata/completion" $ do
    doc <- openDoc "Completion.hs" "haskell"
    _ <- skipManyTill loggingNotification (count 2 noDiagnostics)

    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 `shouldBe` "LANGUAGE"
      item ^. kind `shouldBe` Just CiKeyword
      item ^. insertTextFormat `shouldBe` Just Snippet
      item ^. insertText `shouldBe` Just "LANGUAGE ${1:extension} #-}"

  it "completes pragmas no close" $ runSession hieCommand fullCaps "test/testdata/completion" $ do
    doc <- openDoc "Completion.hs" "haskell"
    _ <- skipManyTill loggingNotification (count 2 noDiagnostics)

    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 `shouldBe` "LANGUAGE"
      item ^. kind `shouldBe` Just CiKeyword
      item ^. insertTextFormat `shouldBe` Just Snippet
      item ^. insertText `shouldBe` Just "LANGUAGE ${1:extension}"

  it "completes options pragma" $ runSession hieCommand fullCaps "test/testdata/completion" $ do
    doc <- openDoc "Completion.hs" "haskell"
    _ <- skipManyTill loggingNotification (count 2 noDiagnostics)

    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 `shouldBe` "OPTIONS_GHC"
      item ^. kind `shouldBe` Just CiKeyword
      item ^. insertTextFormat `shouldBe` Just Snippet
      item ^. insertText `shouldBe` Just ("OPTIONS_GHC -${1:option} #-}")

  -- -----------------------------------

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

    _ <- skipManyTill loggingNotification (count 2 noDiagnostics)

    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 `shouldBe` "Wno-redundant-constraints"
      item ^. kind `shouldBe` Just CiKeyword
      item ^. insertTextFormat `shouldBe` Nothing
      item ^. insertText `shouldBe` Nothing

  -- -----------------------------------

  it "completes with no prefix" $ runSession hieCommand fullCaps "test/testdata/completion" $ do
    doc <- openDoc "Completion.hs" "haskell"
    _ <- skipManyTill loggingNotification (count 2 noDiagnostics)
    compls <- getCompletions doc (Position 5 7)
    liftIO $ filter ((== "!!") . (^. label)) compls `shouldNotSatisfy` null

  -- See https://github.com/haskell/haskell-ide-engine/issues/903
  it "strips compiler generated stuff from completions" $ runSession hieCommand fullCaps "test/testdata/completion" $ do
    doc <- openDoc "DupRecFields.hs" "haskell"
    _ <- skipManyTill loggingNotification (count 2 noDiagnostics)

    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 `shouldBe` "accessor"
      item ^. kind `shouldBe` Just CiFunction
      item ^. detail `shouldBe` Just "Two -> Int\nDupRecFields"
      item ^. insertText `shouldBe` Just "accessor ${1:Two}"

  describe "contexts" $ do
    it "only provides type suggestions" $ runSession hieCommand fullCaps "test/testdata/completion" $ do
      doc <- openDoc "Context.hs" "haskell"
      _ <- skipManyTill loggingNotification (count 2 noDiagnostics)
      compls <- getCompletions doc (Position 2 17)
      liftIO $ do
        compls `shouldContainCompl` "Integer"
        compls `shouldNotContainCompl` "interact"

    it "only provides type suggestions" $ runSession hieCommand fullCaps "test/testdata/completion" $ do
      doc <- openDoc "Context.hs" "haskell"
      _ <- skipManyTill loggingNotification (count 2 noDiagnostics)
      compls <- getCompletions doc (Position 3 9)
      liftIO $ do
        compls `shouldContainCompl` "abs"
        compls `shouldNotContainCompl` "Applicative"

    -- This currently fails if it takes too long to typecheck the module
    -- it "completes qualified type suggestions" $ runSession hieCommand fullCaps "test/testdata/completion" $ do
    --   doc <- openDoc "Context.hs" "haskell"
    --   _ <- skipManyTill loggingNotification (count 2 noDiagnostics)
    --   let te = TextEdit (Range (Position 2 17) (Position 2 17)) " -> Conc."
    --   _ <- applyEdit doc te
    --   compls <- getCompletions doc (Position 2 26)
    --   liftIO $ do
    --     compls `shouldNotContainCompl` "forkOn"
    --     compls `shouldContainCompl` "MVar"
    --     compls `shouldContainCompl` "Chan"

  it "have implicit foralls on basic polymorphic types" $ runSession hieCommand fullCaps "test/testdata/completion" $ do
    doc <- openDoc "Completion.hs" "haskell"
    _ <- skipManyTill loggingNotification (count 2 noDiagnostics)
    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 $
      item ^. detail `shouldBe` Just "a -> a\nPrelude"

  it "have implicit foralls with multiple type variables" $ runSession hieCommand fullCaps "test/testdata/completion" $ do
    doc <- openDoc "Completion.hs" "haskell"
    _ <- skipManyTill loggingNotification (count 2 noDiagnostics)
    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 `shouldBe` Just "(a -> b -> c) -> b -> a -> c\nPrelude"

  describe "snippets" $ do
    it "work for argumentless constructors" $ runSession hieCommand fullCaps "test/testdata/completion" $ do
      doc <- openDoc "Completion.hs" "haskell"
      _ <- skipManyTill loggingNotification (count 2 noDiagnostics)

      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 `shouldBe` Just Snippet
        item ^. insertText `shouldBe` Just "Nothing"

    it "work for polymorphic types" $ runSession hieCommand fullCaps "test/testdata/completion" $ do
      doc <- openDoc "Completion.hs" "haskell"
      _ <- skipManyTill loggingNotification (count 2 noDiagnostics)

      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 `shouldBe` "foldl"
        item ^. kind `shouldBe` Just CiFunction
        item ^. insertTextFormat `shouldBe` Just Snippet
        item ^. insertText `shouldBe` Just "foldl ${1:b -> a -> b} ${2:b} ${3:t a}"

    it "work for complex types" $ runSession hieCommand fullCaps "test/testdata/completion" $ do
      doc <- openDoc "Completion.hs" "haskell"
      _ <- skipManyTill loggingNotification (count 2 noDiagnostics)

      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 `shouldBe` "mapM"
        item ^. kind `shouldBe` Just CiFunction
        item ^. insertTextFormat `shouldBe` Just Snippet
        item ^. insertText `shouldBe` Just "mapM ${1:a -> m b} ${2:t a}"

    it "respects lsp configuration" $ runSession hieCommand fullCaps "test/testdata/completion" $ do
      doc <- openDoc "Completion.hs" "haskell"
      _ <- skipManyTill loggingNotification (count 2 noDiagnostics)

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

      sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams config)

      checkNoSnippets doc

    it "respects client capabilities" $ runSession hieCommand noSnippetsCaps "test/testdata/completion" $ do
      doc <- openDoc "Completion.hs" "haskell"
      _ <- skipManyTill loggingNotification (count 2 noDiagnostics)

      checkNoSnippets doc
  where
    compls `shouldContainCompl` x  =
      filter ((== x) . (^. label)) compls `shouldNotSatisfy` null
    compls `shouldNotContainCompl` x =
      filter ((== x) . (^. label)) compls `shouldSatisfy` null

    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 `shouldBe` "foldl"
        item ^. kind `shouldBe` Just CiFunction
        item ^. insertTextFormat `shouldBe` Just PlainText
        item ^. insertText `shouldBe` Nothing
    noSnippetsCaps = (textDocument . _Just . completion . _Just . completionItem . _Just . snippetSupport ?~ False) fullCaps