diff --git a/hls-pragmas-plugin.cabal b/hls-pragmas-plugin.cabal --- a/hls-pragmas-plugin.cabal +++ b/hls-pragmas-plugin.cabal @@ -1,6 +1,6 @@ cabal-version: 2.4 name: hls-pragmas-plugin -version: 1.0.2.1 +version: 1.0.3.0 synopsis: Pragmas plugin for Haskell Language Server description: Please see the README on GitHub at @@ -18,6 +18,7 @@ test/testdata/*.yaml library + buildable: True exposed-modules: Ide.Plugin.Pragmas hs-source-dirs: src build-depends: @@ -25,18 +26,19 @@ , extra , fuzzy , ghc - , ghcide ^>=1.6 || ^>=1.7 - , hls-plugin-api ^>=1.3 || ^>=1.4 + , ghcide ^>=1.8 + , hls-plugin-api ^>=1.5 , lens , lsp , text , transformers , unordered-containers , containers - + ghc-options: -Wall -Wno-name-shadowing default-language: Haskell2010 test-suite tests + buildable: True type: exitcode-stdio-1.0 default-language: Haskell2010 hs-source-dirs: test @@ -46,7 +48,7 @@ , base , filepath , hls-pragmas-plugin - , hls-test-utils ^>=1.3 + , hls-test-utils ^>=1.4 , lens , lsp-types , text diff --git a/src/Ide/Plugin/Pragmas.hs b/src/Ide/Plugin/Pragmas.hs --- a/src/Ide/Plugin/Pragmas.hs +++ b/src/Ide/Plugin/Pragmas.hs @@ -10,55 +10,26 @@ -- | 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 Development.IDE.Plugin.Completions (ghcideCompletionsPluginPriority) +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 -- --------------------------------------------------------------------- @@ -66,6 +37,7 @@ descriptor plId = (defaultPluginDescriptor plId) { pluginHandlers = mkPluginHandler J.STextDocumentCodeAction codeActionProvider <> mkPluginHandler J.STextDocumentCompletion completion + , pluginPriority = ghcideCompletionsPluginPriority + 1 } -- --------------------------------------------------------------------- @@ -193,7 +165,9 @@ -- Language Version Extensions , "Haskell98" , "Haskell2010" - -- Maybe, GHC 2021 after its release? +#if MIN_VERSION_ghc(9,2,0) + , "GHC2021" +#endif ] -- --------------------------------------------------------------------- @@ -214,59 +188,67 @@ = 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 +263,8 @@ | 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/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/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 @@ [ codeActionTests , codeActionTests' , completionTests + , completionSnippetTests ] codeActionTests :: TestTree @@ -69,6 +71,9 @@ , codeActionTest "adds TypeSynonymInstances pragma" "NeedsPragmas" [("Add \"TypeSynonymInstances\"", "Contains TypeSynonymInstances code action"), ("Add \"FlexibleInstances\"", "Contains FlexibleInstances code action")] ] +ghc94regression :: String +ghc94regression = "to be reported" + codeActionTest :: String -> FilePath -> [(T.Text, String)] -> TestTree codeActionTest testComment fp actions = goldenWithPragmas testComment fp $ \doc -> do @@ -77,7 +82,7 @@ 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 @@ -86,7 +91,7 @@ codeActionTests' = testGroup "additional code actions" [ - goldenWithPragmas "no duplication" "NamedFieldPuns" $ \doc -> do + goldenWithPragmas "no duplication" "NamedFieldPuns" $ \doc -> do _ <- waitForDiagnosticsFrom doc cas <- map fromAction <$> getCodeActions doc (Range (Position 8 9) (Position 8 9)) ca <- liftIO $ case cas of @@ -105,7 +110,7 @@ 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,7 +119,20 @@ , 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] =