Fix duplication of code actions for adding NamedFieldPuns

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

test/functional/FunctionalCodeAction.hs

@@ -517,6 +517,36 @@ 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
+            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
+
+            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
     ]
 

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

test/testdata/addPragmas/hie.yaml

@@ -3,3 +3,4 @@ cradle:
     arguments:
       - "NeedsPragmas"
       - "TypeApplications"
+      - "NamedFieldPuns"