diff --git a/plugins/default/src/Ide/Plugin/Pragmas.hs b/plugins/default/src/Ide/Plugin/Pragmas.hs index 040466da44..ca595873f2 100644 --- a/plugins/default/src/Ide/Plugin/Pragmas.hs +++ b/plugins/default/src/Ide/Plugin/Pragmas.hs @@ -67,10 +67,8 @@ codeActionProvider _ state _plId docId _ (J.CodeActionContext (J.List diags) _mo let mFile = docId ^. J.uri & uriToFilePath <&> toNormalizedFilePath' pm <- fmap join $ runAction "addPragma" state $ getParsedModule `traverse` mFile let dflags = ms_hspp_opts . pm_mod_summary <$> pm - -- Filter diagnostics that are from ghcmod - ghcDiags = filter (\d -> d ^. J.source == Just "typecheck") diags - -- Get all potential Pragmas for all diagnostics. - pragmas = concatMap (\d -> genPragma dflags (d ^. J.message)) ghcDiags + -- Get all potential Pragmas for all diagnostics. + pragmas = concatMap (\d -> genPragma dflags (d ^. J.message)) diags cmds <- mapM mkCodeAction pragmas return $ Right $ List cmds where @@ -81,13 +79,17 @@ codeActionProvider _ state _plId docId _ (J.CodeActionContext (J.List diags) _mo edit = mkPragmaEdit (docId ^. J.uri) pragmaName return codeAction - genPragma mDynflags target - | Just dynFlags <- mDynflags, - -- GHC does not export 'OnOff', so we have to view it as string - disabled <- [ e | Just e <- T.stripPrefix "Off " . T.pack . prettyPrint <$> extensions dynFlags] - = [ r | r <- findPragma target, r `notElem` disabled] - | otherwise = [] - + genPragma mDynflags target = + [ r | r <- findPragma target, r `notElem` disabled] + where + disabled + | Just dynFlags <- mDynflags + -- GHC does not export 'OnOff', so we have to view it as string + = [ e | Just e <- T.stripPrefix "Off " . T.pack . prettyPrint <$> extensions dynFlags] + | otherwise + -- When the module failed to parse, we don't have access to its + -- dynFlags. In that case, simply don't disable any pragmas. + = [] -- --------------------------------------------------------------------- diff --git a/test/functional/FunctionalCodeAction.hs b/test/functional/FunctionalCodeAction.hs index 960e0bb0d1..f02b500cd1 100644 --- a/test/functional/FunctionalCodeAction.hs +++ b/test/functional/FunctionalCodeAction.hs @@ -425,6 +425,7 @@ missingPragmaTests = testGroup "missing pragma warning code actions" [ contents <- documentContents doc let expected = [ "{-# LANGUAGE TypeSynonymInstances #-}" + , "module NeedsPragmas where" , "" , "import GHC.Generics" , "" @@ -443,6 +444,30 @@ missingPragmaTests = testGroup "missing pragma warning code actions" [ ] liftIO $ (T.lines contents) @?= expected + + , testCase "Adds TypeApplications pragma" $ do + runSession hlsCommand fullCaps "test/testdata/addPragmas" $ do + doc <- openDoc "TypeApplications.hs" "haskell" + + _ <- waitForDiagnosticsFrom doc + cas <- map fromAction <$> getAllCodeActions doc + + liftIO $ "Add \"TypeApplications\"" `elem` map (^. L.title) cas @? "Contains TypeApplications code action" + + executeCodeAction $ head cas + + contents <- documentContents doc + + let expected = + [ "{-# LANGUAGE TypeApplications #-}" + , "{-# LANGUAGE ScopedTypeVariables #-}" + , "module TypeApplications where" + , "" + , "foo :: forall a. a -> a" + , "foo = id @a" + ] + + liftIO $ (T.lines contents) @?= expected ] unusedTermTests :: TestTree diff --git a/test/testdata/addPragmas/NeedsPragmas.hs b/test/testdata/addPragmas/NeedsPragmas.hs index e82ad67ec2..18a8853972 100644 --- a/test/testdata/addPragmas/NeedsPragmas.hs +++ b/test/testdata/addPragmas/NeedsPragmas.hs @@ -1,3 +1,4 @@ +module NeedsPragmas where import GHC.Generics diff --git a/test/testdata/addPragmas/TypeApplications.hs b/test/testdata/addPragmas/TypeApplications.hs new file mode 100644 index 0000000000..55e56bdd9d --- /dev/null +++ b/test/testdata/addPragmas/TypeApplications.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE ScopedTypeVariables #-} +module TypeApplications where + +foo :: forall a. a -> a +foo = id @a diff --git a/test/testdata/addPragmas/hie.yaml b/test/testdata/addPragmas/hie.yaml index 3e0a999a90..2c7d1c81c0 100644 --- a/test/testdata/addPragmas/hie.yaml +++ b/test/testdata/addPragmas/hie.yaml @@ -2,3 +2,4 @@ cradle: direct: arguments: - "NeedsPragmas" + - "TypeApplications" diff --git a/test/testdata/addPragmas/test.cabal b/test/testdata/addPragmas/test.cabal index 68ab327aec..eab3c651d2 100644 --- a/test/testdata/addPragmas/test.cabal +++ b/test/testdata/addPragmas/test.cabal @@ -10,8 +10,9 @@ category: Web build-type: Simple cabal-version: >=1.10 -executable p - main-is: NeedsPragmas.hs +library + exposed-modules: NeedsPragmas + TypeApplications hs-source-dirs: . build-depends: base >= 4.7 && < 5 default-language: Haskell2010