From 78a5d2f531afda4d164951935c223fed6ee682a0 Mon Sep 17 00:00:00 2001 From: Potato Hatsue <1793913507@qq.com> Date: Tue, 9 Feb 2021 17:02:42 +0800 Subject: [PATCH 1/3] Fix duplication of code actions for adding NamedFieldPuns --- plugins/default/src/Ide/Plugin/Pragmas.hs | 12 ++-------- test/functional/FunctionalCodeAction.hs | 27 ++++++++++++++++++++++ test/testdata/addPragmas/NamedFieldPuns.hs | 9 ++++++++ test/testdata/addPragmas/hie.yaml | 1 + test/testdata/addPragmas/test.cabal | 19 --------------- 5 files changed, 39 insertions(+), 29 deletions(-) create mode 100644 test/testdata/addPragmas/NamedFieldPuns.hs delete mode 100644 test/testdata/addPragmas/test.cabal diff --git a/plugins/default/src/Ide/Plugin/Pragmas.hs b/plugins/default/src/Ide/Plugin/Pragmas.hs index db08bc5249..2d113ce248 100644 --- a/plugins/default/src/Ide/Plugin/Pragmas.hs +++ b/plugins/default/src/Ide/Plugin/Pragmas.hs @@ -11,11 +11,9 @@ module Ide.Plugin.Pragmas ) where import Control.Lens hiding (List) -import Data.Aeson import qualified Data.HashMap.Strict as H import qualified Data.Text as T import Development.IDE as D -import qualified GHC.Generics as Generics import Ide.Types import Language.Haskell.LSP.Types import qualified Language.Haskell.LSP.Types as J @@ -26,6 +24,7 @@ import Development.IDE.GHC.Compat import qualified Language.Haskell.LSP.Core as LSP import qualified Language.Haskell.LSP.VFS as VFS import qualified Text.Fuzzy as Fuzzy +import Data.List.Extra (nubOrd) -- --------------------------------------------------------------------- @@ -37,13 +36,6 @@ descriptor plId = (defaultPluginDescriptor plId) -- --------------------------------------------------------------------- --- | Parameters for the addPragma PluginCommand. -data AddPragmaParams = AddPragmaParams - { file :: J.Uri -- ^ Uri of the file to add the pragma to - , pragma :: T.Text -- ^ Name of the Pragma to add - } - deriving (Show, Eq, Generics.Generic, ToJSON, FromJSON) - -- | Add a Pragma to the given URI at the top of the file. -- Pragma is added to the first line of the Uri. -- It is assumed that the pragma name is a valid pragma, @@ -68,7 +60,7 @@ codeActionProvider _ state _plId docId _ (J.CodeActionContext (J.List diags) _mo pm <- fmap join $ runAction "addPragma" state $ getParsedModule `traverse` mFile let dflags = ms_hspp_opts . pm_mod_summary <$> pm -- Get all potential Pragmas for all diagnostics. - pragmas = concatMap (\d -> genPragma dflags (d ^. J.message)) diags + pragmas = nubOrd $ concatMap (\d -> genPragma dflags (d ^. J.message)) diags cmds <- mapM mkCodeAction pragmas return $ Right $ List cmds where diff --git a/test/functional/FunctionalCodeAction.hs b/test/functional/FunctionalCodeAction.hs index ca38bbb83a..1d9800eb0e 100644 --- a/test/functional/FunctionalCodeAction.hs +++ b/test/functional/FunctionalCodeAction.hs @@ -517,6 +517,33 @@ missingPragmaTests = testGroup "missing pragma warning code actions" [ , "foo = id @a" ] + liftIO $ T.lines contents @?= expected + , testCase "No duplication" $ do + runSession hlsCommand fullCaps "test/testdata/addPragmas" $ do + doc <- openDoc "NamedFieldPuns.hs" "haskell" + + _ <- waitForDiagnosticsFrom doc + [ca] <- map fromAction <$> getAllCodeActions doc + + liftIO $ (ca ^. L.title == "Add \"NamedFieldPuns\"") @? "NamedFieldPuns code action" + + executeCodeAction ca + + contents <- documentContents doc + + let expected = + [ "{-# LANGUAGE NamedFieldPuns #-}" + , "module NamedFieldPuns where" + , "" + , "data Record = Record" + , " { a :: Int," + , " b :: Double," + , " c :: String" + , " }" + , "" + , "f Record{a, b} = a" + ] + liftIO $ T.lines contents @?= expected ] diff --git a/test/testdata/addPragmas/NamedFieldPuns.hs b/test/testdata/addPragmas/NamedFieldPuns.hs new file mode 100644 index 0000000000..6651685e70 --- /dev/null +++ b/test/testdata/addPragmas/NamedFieldPuns.hs @@ -0,0 +1,9 @@ +module NamedFieldPuns where + +data Record = Record + { a :: Int, + b :: Double, + c :: String + } + +f Record{a, b} = a diff --git a/test/testdata/addPragmas/hie.yaml b/test/testdata/addPragmas/hie.yaml index 2c7d1c81c0..1a9f518b52 100644 --- a/test/testdata/addPragmas/hie.yaml +++ b/test/testdata/addPragmas/hie.yaml @@ -3,3 +3,4 @@ cradle: arguments: - "NeedsPragmas" - "TypeApplications" + - "NamedFieldPuns" diff --git a/test/testdata/addPragmas/test.cabal b/test/testdata/addPragmas/test.cabal deleted file mode 100644 index eab3c651d2..0000000000 --- a/test/testdata/addPragmas/test.cabal +++ /dev/null @@ -1,19 +0,0 @@ -name: test -version: 0.1.0.0 --- synopsis: --- description: -license: BSD3 -author: Author name here -maintainer: example@example.com -copyright: 2017 Author name here -category: Web -build-type: Simple -cabal-version: >=1.10 - -library - exposed-modules: NeedsPragmas - TypeApplications - hs-source-dirs: . - build-depends: base >= 4.7 && < 5 - default-language: Haskell2010 - ghc-options: -Wall \ No newline at end of file From 42dca3b8b26720c7386ee7457b0ebe758a43bf50 Mon Sep 17 00:00:00 2001 From: Potato Hatsue <1793913507@qq.com> Date: Tue, 9 Feb 2021 19:33:03 +0800 Subject: [PATCH 2/3] Avoid pattern matching in do notation --- test/functional/FunctionalCodeAction.hs | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/test/functional/FunctionalCodeAction.hs b/test/functional/FunctionalCodeAction.hs index 1d9800eb0e..ddc57e76fc 100644 --- a/test/functional/FunctionalCodeAction.hs +++ b/test/functional/FunctionalCodeAction.hs @@ -523,7 +523,10 @@ missingPragmaTests = testGroup "missing pragma warning code actions" [ doc <- openDoc "NamedFieldPuns.hs" "haskell" _ <- waitForDiagnosticsFrom doc - [ca] <- map fromAction <$> getAllCodeActions doc + cas <- map fromAction <$> getAllCodeActions doc + + liftIO $ length cas == 1 @? "Expected one code action, but got: " <> show cas + let ca = head cas liftIO $ (ca ^. L.title == "Add \"NamedFieldPuns\"") @? "NamedFieldPuns code action" From cd83a3ce569564a2301bd0ee6fc3941d651043e9 Mon Sep 17 00:00:00 2001 From: Potato Hatsue <1793913507@qq.com> Date: Tue, 9 Feb 2021 22:03:57 +0800 Subject: [PATCH 3/3] Add range --- test/functional/FunctionalCodeAction.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/test/functional/FunctionalCodeAction.hs b/test/functional/FunctionalCodeAction.hs index ddc57e76fc..80b1c75296 100644 --- a/test/functional/FunctionalCodeAction.hs +++ b/test/functional/FunctionalCodeAction.hs @@ -523,7 +523,7 @@ missingPragmaTests = testGroup "missing pragma warning code actions" [ doc <- openDoc "NamedFieldPuns.hs" "haskell" _ <- waitForDiagnosticsFrom doc - cas <- map fromAction <$> getAllCodeActions doc + cas <- map fromAction <$> getCodeActions doc (Range (Position 8 9) (Position 8 9)) liftIO $ length cas == 1 @? "Expected one code action, but got: " <> show cas let ca = head cas