diff --git a/hls-test-utils/src/Test/Hls.hs b/hls-test-utils/src/Test/Hls.hs index 227bec3e06..c0af35b29a 100644 --- a/hls-test-utils/src/Test/Hls.hs +++ b/hls-test-utils/src/Test/Hls.hs @@ -47,8 +47,8 @@ import Data.Aeson (Result (Success), import qualified Data.Aeson as A import Data.ByteString.Lazy (ByteString) import Data.Default (def) -import Data.Maybe (fromMaybe) import qualified Data.Map as M +import Data.Maybe (fromMaybe) import qualified Data.Text as T import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy.Encoding as TL @@ -69,7 +69,8 @@ import Development.IDE.Types.Logger (Logger (Logger), import Development.IDE.Types.Options import GHC.IO.Handle import GHC.Stack (emptyCallStack) -import Ide.Plugin.Config (Config, formattingProvider, PluginConfig, plugins) +import Ide.Plugin.Config (Config, PluginConfig, + formattingProvider, plugins) import Ide.PluginUtils (idePluginsToPluginDesc, pluginDescToIdePlugins) import Ide.Types @@ -208,9 +209,9 @@ runSessionWithServer' plugins conf sconf caps root s = withLock lock $ keepCurre arguments@Arguments{ argsHlsPlugins, argsIdeOptions, argsLogger } = defaultArguments (cmapWithPrio LogIDEMain recorder) logger hlsPlugins = - idePluginsToPluginDesc argsHlsPlugins + plugins ++ [Test.blockCommandDescriptor "block-command", Test.plugin] - ++ plugins + ++ idePluginsToPluginDesc argsHlsPlugins ideOptions = \config ghcSession -> let defIdeOptions = argsIdeOptions config ghcSession in defIdeOptions diff --git a/hls-test-utils/src/Test/Hls/Util.hs b/hls-test-utils/src/Test/Hls/Util.hs index 82c335d3b8..eab8fb8313 100644 --- a/hls-test-utils/src/Test/Hls/Util.hs +++ b/hls-test-utils/src/Test/Hls/Util.hs @@ -32,6 +32,7 @@ module Test.Hls.Util , knownBrokenOnWindows , knownBrokenForGhcVersions , knownBrokenInEnv + , onlyWorkForGhcVersions , setupBuildToolFiles , SymbolLocation , waitForDiagnosticsFrom @@ -149,6 +150,14 @@ ignoreInEnv envSpecs reason ignoreForGhcVersions :: [GhcVersion] -> String -> TestTree -> TestTree ignoreForGhcVersions vers = ignoreInEnv (map GhcVer vers) +-- | Mark as broken if GHC does not match only work versions. +onlyWorkForGhcVersions :: [GhcVersion] -> String -> TestTree -> TestTree +onlyWorkForGhcVersions vers reason = + if ghcVersion `elem` vers + then id + else expectFailBecause reason + +-- | Ignore the test if GHC does not match only work versions. onlyRunForGhcVersions :: [GhcVersion] -> String -> TestTree -> TestTree onlyRunForGhcVersions vers = if ghcVersion `elem` vers diff --git a/plugins/hls-pragmas-plugin/hls-pragmas-plugin.cabal b/plugins/hls-pragmas-plugin/hls-pragmas-plugin.cabal index 0bd5835367..9576169ce8 100644 --- a/plugins/hls-pragmas-plugin/hls-pragmas-plugin.cabal +++ b/plugins/hls-pragmas-plugin/hls-pragmas-plugin.cabal @@ -33,7 +33,7 @@ library , transformers , unordered-containers , containers - + ghc-options: -Wall -Wno-name-shadowing default-language: Haskell2010 test-suite tests diff --git a/plugins/hls-pragmas-plugin/src/Ide/Plugin/Pragmas.hs b/plugins/hls-pragmas-plugin/src/Ide/Plugin/Pragmas.hs index bb7a809744..75f53e26a5 100644 --- a/plugins/hls-pragmas-plugin/src/Ide/Plugin/Pragmas.hs +++ b/plugins/hls-pragmas-plugin/src/Ide/Plugin/Pragmas.hs @@ -10,55 +10,25 @@ -- | Provides code actions to add missing pragmas (whenever GHC suggests to) module Ide.Plugin.Pragmas ( descriptor + -- For testing + , validPragmas ) where -import Control.Applicative ((<|>)) -import Control.Lens hiding (List) -import Control.Monad (join) -import Control.Monad.IO.Class (MonadIO (liftIO)) -import Control.Monad.Trans.State.Strict (State) -import Data.Bits (Bits (bit, complement, setBit, (.&.))) -import Data.Char (isSpace) -import qualified Data.Char as Char -import Data.Coerce (coerce) -import Data.Functor (void, ($>)) -import qualified Data.HashMap.Strict as H -import qualified Data.List as List -import Data.List.Extra (nubOrdOn) -import qualified Data.Map.Strict as Map -import Data.Maybe (catMaybes, listToMaybe, - mapMaybe) -import qualified Data.Maybe as Maybe -import Data.Ord (Down (Down)) -import Data.Semigroup (Semigroup ((<>))) -import qualified Data.Text as T -import Data.Word (Word64) -import Development.IDE as D (Diagnostic (Diagnostic, _code, _message), - GhcSession (GhcSession), - HscEnvEq (hscEnv), - IdeState, List (List), - ParseResult (POk), - Position (Position), - Range (Range), Uri, - getFileContents, - getParsedModule, - printOutputable, runAction, - srcSpanToRange, - toNormalizedUri, - uriToFilePath', - useWithStale) +import Control.Lens hiding (List) +import Control.Monad.IO.Class (MonadIO (liftIO)) +import qualified Data.HashMap.Strict as H +import Data.List.Extra (nubOrdOn) +import Data.Maybe (catMaybes) +import qualified Data.Text as T +import Development.IDE import Development.IDE.GHC.Compat -import Development.IDE.GHC.Compat.Util (StringBuffer, atEnd, - nextChar, - stringToStringBuffer) -import qualified Development.IDE.Spans.Pragmas as Pragmas -import Development.IDE.Types.HscEnvEq (HscEnvEq, hscEnv) +import qualified Development.IDE.Spans.Pragmas as Pragmas import Ide.Types -import qualified Language.LSP.Server as LSP -import qualified Language.LSP.Types as J -import qualified Language.LSP.Types.Lens as J -import qualified Language.LSP.VFS as VFS -import qualified Text.Fuzzy as Fuzzy +import qualified Language.LSP.Server as LSP +import qualified Language.LSP.Types as J +import qualified Language.LSP.Types.Lens as J +import qualified Language.LSP.VFS as VFS +import qualified Text.Fuzzy as Fuzzy -- --------------------------------------------------------------------- @@ -193,7 +163,9 @@ allPragmas = -- Language Version Extensions , "Haskell98" , "Haskell2010" - -- Maybe, GHC 2021 after its release? +#if MIN_VERSION_ghc(9,2,0) + , "GHC2021" +#endif ] -- --------------------------------------------------------------------- @@ -214,59 +186,67 @@ completion _ide _ complParams = do = J.List $ map buildCompletion (Fuzzy.simpleFilter (VFS.prefixText pfix) allPragmas) | "{-# options_ghc" `T.isPrefixOf` line - = J.List $ map mkExtCompl + = J.List $ map buildCompletion (Fuzzy.simpleFilter (VFS.prefixText pfix) flags) | "{-#" `T.isPrefixOf` line - = J.List $ map (\(a, b, c) -> mkPragmaCompl (a <> suffix) b c) validPragmas + = J.List $ [ mkPragmaCompl (a <> suffix) b c + | (a, b, c, w) <- validPragmas, w == NewLine ] | otherwise - = J.List [] + = J.List $ [ mkPragmaCompl (prefix <> a <> suffix) b c + | (a, b, c, _) <- validPragmas, Fuzzy.test word b] where line = T.toLower $ VFS.fullLine pfix + word = VFS.prefixText pfix + -- Not completely correct, may fail if more than one "{-#" exist + -- , we can ignore it since it rarely happen. + prefix + | "{-# " `T.isInfixOf` line = "" + | "{-#" `T.isInfixOf` line = " " + | otherwise = "{-# " suffix - | "#-}" `T.isSuffixOf` line = " " - | "-}" `T.isSuffixOf` line = " #" - | "}" `T.isSuffixOf` line = " #-" + | " #-}" `T.isSuffixOf` line = "" + | "#-}" `T.isSuffixOf` line = " " + | "-}" `T.isSuffixOf` line = " #" + | "}" `T.isSuffixOf` line = " #-" | otherwise = " #-}" result Nothing = J.List [] - buildCompletion p = - J.CompletionItem - { _label = p, - _kind = Just J.CiKeyword, - _tags = Nothing, - _detail = Nothing, - _documentation = Nothing, - _deprecated = Nothing, - _preselect = Nothing, - _sortText = Nothing, - _filterText = Nothing, - _insertText = Nothing, - _insertTextFormat = Nothing, - _insertTextMode = Nothing, - _textEdit = Nothing, - _additionalTextEdits = Nothing, - _commitCharacters = Nothing, - _command = Nothing, - _xdata = Nothing - } _ -> return $ J.List [] ----------------------------------------------------------------------- -validPragmas :: [(T.Text, T.Text, T.Text)] + +-- | Pragma where exist +data AppearWhere = + NewLine + -- ^Must be on a new line + | CanInline + -- ^Can appear in the line + deriving (Show, Eq) + +validPragmas :: [(T.Text, T.Text, T.Text, AppearWhere)] validPragmas = - [ ("LANGUAGE ${1:extension}" , "LANGUAGE", "{-# LANGUAGE #-}") - , ("OPTIONS_GHC -${1:option}" , "OPTIONS_GHC", "{-# OPTIONS_GHC #-}") - , ("INLINE ${1:function}" , "INLINE", "{-# INLINE #-}") - , ("NOINLINE ${1:function}" , "NOINLINE", "{-# NOINLINE #-}") - , ("INLINABLE ${1:function}" , "INLINABLE", "{-# INLINABLE #-}") - , ("WARNING ${1:message}" , "WARNING", "{-# WARNING #-}") - , ("DEPRECATED ${1:message}" , "DEPRECATED", "{-# DEPRECATED #-}") - , ("ANN ${1:annotation}" , "ANN", "{-# ANN #-}") - , ("RULES" , "RULES", "{-# RULES #-}") - , ("SPECIALIZE ${1:function}" , "SPECIALIZE", "{-# SPECIALIZE #-}") - , ("SPECIALIZE INLINE ${1:function}" , "SPECIALIZE INLINE", "{-# SPECIALIZE INLINE #-}") + [ ("LANGUAGE ${1:extension}" , "LANGUAGE" , "{-# LANGUAGE #-}" , NewLine) + , ("OPTIONS_GHC -${1:option}" , "OPTIONS_GHC" , "{-# OPTIONS_GHC #-}" , NewLine) + , ("INLINE ${1:function}" , "INLINE" , "{-# INLINE #-}" , NewLine) + , ("NOINLINE ${1:function}" , "NOINLINE" , "{-# NOINLINE #-}" , NewLine) + , ("INLINABLE ${1:function}" , "INLINABLE" , "{-# INLINABLE #-}" , NewLine) + , ("WARNING ${1:message}" , "WARNING" , "{-# WARNING #-}" , CanInline) + , ("DEPRECATED ${1:message}" , "DEPRECATED" , "{-# DEPRECATED #-}" , CanInline) + , ("ANN ${1:annotation}" , "ANN" , "{-# ANN #-}" , NewLine) + , ("RULES" , "RULES" , "{-# RULES #-}" , NewLine) + , ("SPECIALIZE ${1:function}" , "SPECIALIZE" , "{-# SPECIALIZE #-}" , NewLine) + , ("SPECIALIZE INLINE ${1:function}", "SPECIALIZE INLINE", "{-# SPECIALIZE INLINE #-}", NewLine) + , ("SPECIALISE ${1:function}" , "SPECIALISE" , "{-# SPECIALISE #-}" , NewLine) + , ("SPECIALISE INLINE ${1:function}", "SPECIALISE INLINE", "{-# SPECIALISE INLINE #-}", NewLine) + , ("MINIMAL ${1:functions}" , "MINIMAL" , "{-# MINIMAL #-}" , CanInline) + , ("UNPACK" , "UNPACK" , "{-# UNPACK #-}" , CanInline) + , ("NOUNPACK" , "NOUNPACK" , "{-# NOUNPACK #-}" , CanInline) + , ("COMPLETE ${1:function}" , "COMPLETE" , "{-# COMPLETE #-}" , NewLine) + , ("OVERLAPPING" , "OVERLAPPING" , "{-# OVERLAPPING #-}" , CanInline) + , ("OVERLAPPABLE" , "OVERLAPPABLE" , "{-# OVERLAPPABLE #-}" , CanInline) + , ("OVERLAPS" , "OVERLAPS" , "{-# OVERLAPS #-}" , CanInline) + , ("INCOHERENT" , "INCOHERENT" , "{-# INCOHERENT #-}" , CanInline) ] - mkPragmaCompl :: T.Text -> T.Text -> T.Text -> J.CompletionItem mkPragmaCompl insertText label detail = J.CompletionItem label (Just J.CiKeyword) Nothing (Just detail) @@ -281,8 +261,8 @@ stripLeading c (s:ss) | otherwise = s:ss -mkExtCompl :: T.Text -> J.CompletionItem -mkExtCompl label = +buildCompletion :: T.Text -> J.CompletionItem +buildCompletion label = J.CompletionItem label (Just J.CiKeyword) Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing diff --git a/plugins/hls-pragmas-plugin/test/Main.hs b/plugins/hls-pragmas-plugin/test/Main.hs index f78261ff55..ec146ef2ef 100644 --- a/plugins/hls-pragmas-plugin/test/Main.hs +++ b/plugins/hls-pragmas-plugin/test/Main.hs @@ -1,21 +1,22 @@ {-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -Wno-incomplete-patterns #-} module Main ( main ) where -import Control.Lens ((^.), (^..), traversed) -import Data.Foldable (find) +import Control.Lens ((<&>), (^.)) import qualified Data.Text as T -import qualified Ide.Plugin.Pragmas as Pragmas +import Ide.Plugin.Pragmas import qualified Language.LSP.Types.Lens as L import System.FilePath import Test.Hls +import Test.Hls.Util (onlyWorkForGhcVersions) main :: IO () main = defaultTestRunner tests pragmasPlugin :: PluginDescriptor IdeState -pragmasPlugin = Pragmas.descriptor "pragmas" +pragmasPlugin = descriptor "pragmas" tests :: TestTree tests = @@ -23,6 +24,7 @@ tests = [ codeActionTests , codeActionTests' , completionTests + , completionSnippetTests ] codeActionTests :: TestTree @@ -77,7 +79,7 @@ codeActionTest testComment fp actions = mapM_ (\(action, contains) -> go action contains cas) actions action <- case cas of (a:_) -> pure a - [] -> liftIO $ assertFailure "Expected non-empty list of code actions" + [] -> liftIO $ assertFailure "Expected non-empty list of code actions" executeCodeAction action where go action contains cas = liftIO $ action `elem` map (^. L.title) cas @? contains @@ -105,7 +107,7 @@ completionTests :: TestTree completionTests = testGroup "completions" [ completionTest "completes pragmas" "Completion.hs" "" "LANGUAGE" (Just Snippet) (Just "LANGUAGE ${1:extension} #-}") (Just "{-# LANGUAGE #-}") [0, 4, 0, 34, 0, 4] - , completionTest "completes pragmas with existing closing pragma bracket" "Completion.hs" "" "LANGUAGE" (Just Snippet) (Just "LANGUAGE ${1:extension} ") (Just "{-# LANGUAGE #-}") [0, 4, 0, 31, 0, 4] + , completionTest "completes pragmas with existing closing pragma bracket" "Completion.hs" "" "LANGUAGE" (Just Snippet) (Just "LANGUAGE ${1:extension}") (Just "{-# LANGUAGE #-}") [0, 4, 0, 31, 0, 4] , completionTest "completes pragmas with existing closing comment bracket" "Completion.hs" "" "LANGUAGE" (Just Snippet) (Just "LANGUAGE ${1:extension} #") (Just "{-# LANGUAGE #-}") [0, 4, 0, 32, 0, 4] , completionTest "completes pragmas with existing closing bracket" "Completion.hs" "" "LANGUAGE" (Just Snippet) (Just "LANGUAGE ${1:extension} #-") (Just "{-# LANGUAGE #-}") [0, 4, 0, 33, 0, 4] , completionTest "completes options pragma" "Completion.hs" "OPTIONS" "OPTIONS_GHC" (Just Snippet) (Just "OPTIONS_GHC -${1:option} #-}") (Just "{-# OPTIONS_GHC #-}") [0, 4, 0, 34, 0, 4] @@ -114,8 +116,21 @@ completionTests = , completionTest "completes language extensions case insensitive" "Completion.hs" "lAnGuaGe Overloaded" "OverloadedStrings" Nothing Nothing Nothing [0, 4, 0, 34, 0, 24] , completionTest "completes the Strict language extension" "Completion.hs" "Str" "Strict" Nothing Nothing Nothing [0, 13, 0, 31, 0, 16] , completionTest "completes No- language extensions" "Completion.hs" "NoOverload" "NoOverloadedStrings" Nothing Nothing Nothing [0, 13, 0, 31, 0, 23] + , onlyWorkForGhcVersions [GHC92] "GHC2021 flag introduced since ghc9.2" $ + completionTest "completes GHC2021 extensions" "Completion.hs" "ghc" "GHC2021" Nothing Nothing Nothing [0, 13, 0, 31, 0, 16] ] +completionSnippetTests :: TestTree +completionSnippetTests = + testGroup "expand snippet to pragma" $ + validPragmas <&> + (\(insertText, label, detail, _) -> + let input = T.toLower $ T.init label + in completionTest (T.unpack label) + "Completion.hs" input label (Just Snippet) + (Just $ "{-# " <> insertText <> " #-}") (Just detail) + [0, 0, 0, 34, 0, fromIntegral $ T.length input]) + completionTest :: String -> String -> T.Text -> T.Text -> Maybe InsertTextFormat -> Maybe T.Text -> Maybe T.Text -> [UInt] -> TestTree completionTest testComment fileName te' label textFormat insertText detail [a, b, c, d, x, y] = testCase testComment $ runSessionWithServer pragmasPlugin testDataDir $ do diff --git a/test/functional/Completion.hs b/test/functional/Completion.hs index d7635e5558..76a661bd8f 100644 --- a/test/functional/Completion.hs +++ b/test/functional/Completion.hs @@ -138,10 +138,10 @@ tests = testGroup "completions" [ , testCase "import second function completion" $ runSession hlsCommand fullCaps "test/testdata/completion" $ do doc <- openDoc "FunctionCompletions.hs" "haskell" - let te = TextEdit (Range (Position 0 41) (Position 0 42)) ", l" + let te = TextEdit (Range (Position 0 39) (Position 0 39)) ", l" _ <- applyEdit doc te - compls <- getCompletions doc (Position 0 41) + compls <- getCompletions doc (Position 0 42) item <- getCompletionByLabel "liftA" compls liftIO $ do item ^. label @?= "liftA"