hls-pragmas-plugin 1.0.2.1 → 1.0.3.0
raw patch · 3 files changed
+101/−99 lines, 3 filesdep ~ghcidedep ~hls-plugin-apidep ~hls-test-utilsPVP ok
version bump matches the API change (PVP)
Dependency ranges changed: ghcide, hls-plugin-api, hls-test-utils
API changes (from Hackage documentation)
+ Ide.Plugin.Pragmas: instance GHC.Classes.Eq Ide.Plugin.Pragmas.AppearWhere
+ Ide.Plugin.Pragmas: instance GHC.Show.Show Ide.Plugin.Pragmas.AppearWhere
+ Ide.Plugin.Pragmas: validPragmas :: [(Text, Text, Text, AppearWhere)]
Files
- hls-pragmas-plugin.cabal +7/−5
- src/Ide/Plugin/Pragmas.hs +69/−87
- test/Main.hs +25/−7
hls-pragmas-plugin.cabal view
@@ -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 <https://github.com/haskell/haskell-language-server#readme>@@ -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
src/Ide/Plugin/Pragmas.hs view
@@ -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
test/Main.hs view
@@ -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] =