From 180c6928354b811ca9e6a5bdc26cdcdbc94e6b5a Mon Sep 17 00:00:00 2001
From: Nick Suchecki <nicksuchecki@gmail.com>
Date: Sat, 26 Feb 2022 23:13:08 -0500
Subject: [PATCH 1/2] Fix defining new function code action
Use `GetParsedModuleWithComments` rather than `GetParsedModule` as the
default `ToCodeAction` instance. The insertion code needs knowledge of
comments in order to properly insert the function definition.
Also swaps out the old default `error "Not Implemented"` definition with
a hole.
---
.../src/Development/IDE/Plugin/CodeAction.hs | 5 +-
.../Development/IDE/Plugin/CodeAction/Args.hs | 2 +-
ghcide/test/exe/Main.hs | 88 ++++++++++++++++---
3 files changed, 78 insertions(+), 17 deletions(-)
diff --git a/ghcide/src/Development/IDE/Plugin/CodeAction.hs b/ghcide/src/Development/IDE/Plugin/CodeAction.hs
index 37a4c7ecbc..7d10ff105b 100644
--- a/ghcide/src/Development/IDE/Plugin/CodeAction.hs
+++ b/ghcide/src/Development/IDE/Plugin/CodeAction.hs
@@ -64,6 +64,8 @@ import qualified GHC.LanguageExtensions as Lang
import Ide.PluginUtils (subRange)
import Ide.Types
import qualified Language.LSP.Server as LSP
+
+
import Language.LSP.Types (CodeAction (..),
CodeActionContext (CodeActionContext, _diagnostics),
CodeActionKind (CodeActionQuickFix, CodeActionUnknown),
@@ -711,7 +713,7 @@ newDefinitionAction IdeOptions{..} parsedModule Range{_start} name typ
, _start `isInsideSrcSpan` l]
, nextLineP <- Position{ _line = _line lastLineP + 1, _character = 0}
= [ ("Define " <> sig
- , [TextEdit (Range nextLineP nextLineP) (T.unlines ["", sig, name <> " = error \"not implemented\""])]
+ , [TextEdit (Range nextLineP nextLineP) (T.unlines ["", sig, name <> " = _"])]
)]
| otherwise = []
where
@@ -719,7 +721,6 @@ newDefinitionAction IdeOptions{..} parsedModule Range{_start} name typ
sig = name <> colon <> T.dropWhileEnd isSpace typ
ParsedModule{pm_parsed_source = L _ HsModule{hsmodDecls}} = parsedModule
-
suggestFillTypeWildcard :: Diagnostic -> [(T.Text, TextEdit)]
suggestFillTypeWildcard Diagnostic{_range=_range,..}
-- Foo.hs:3:8: error:
diff --git a/ghcide/src/Development/IDE/Plugin/CodeAction/Args.hs b/ghcide/src/Development/IDE/Plugin/CodeAction/Args.hs
index 32f5b34aa9..85f100ca66 100644
--- a/ghcide/src/Development/IDE/Plugin/CodeAction/Args.hs
+++ b/ghcide/src/Development/IDE/Plugin/CodeAction/Args.hs
@@ -65,7 +65,7 @@ runGhcideCodeAction state (CodeActionParams _ _ (TextDocumentIdentifier uri) _ra
pure $ localExports <> pkgExports
_ -> pure mempty
caaIdeOptions <- onceIO $ runAction "GhcideCodeActions.getIdeOptions" state getIdeOptions
- caaParsedModule <- onceIO $ runRule GetParsedModule
+ caaParsedModule <- onceIO $ runRule GetParsedModuleWithComments
caaContents <-
onceIO $
runRule GetFileContents >>= \case
diff --git a/ghcide/test/exe/Main.hs b/ghcide/test/exe/Main.hs
index 286c5e98d0..f82cc9509f 100644
--- a/ghcide/test/exe/Main.hs
+++ b/ghcide/test/exe/Main.hs
@@ -55,12 +55,12 @@ import Development.IDE.Test (Cursor,
flushMessages,
getInterfaceFilesDir,
getStoredKeys,
+ isReferenceReady,
+ referenceReady,
standardizeQuotes,
waitForAction,
waitForGC,
- waitForTypecheck,
- isReferenceReady,
- referenceReady)
+ waitForTypecheck)
import Development.IDE.Test.Runfiles
import qualified Development.IDE.Types.Diagnostics as Diagnostics
import Development.IDE.Types.Location
@@ -97,6 +97,7 @@ import Test.QuickCheck
import Control.Concurrent.Async
import Control.Lens (to, (^.))
import Control.Monad.Extra (whenJust)
+import Data.Function ((&))
import Data.IORef
import Data.IORef.Extra (atomicModifyIORef_)
import Data.String (IsString (fromString))
@@ -107,6 +108,18 @@ import qualified Development.IDE.Plugin.HLS.GhcIde as Ghcide
import Development.IDE.Plugin.Test (TestRequest (BlockSeconds),
WaitForIdeRuleResult (..),
blockCommandId)
+import Development.IDE.Types.Logger (Logger (Logger),
+ LoggingColumn (DataColumn, PriorityColumn),
+ Pretty (pretty),
+ Priority (Debug),
+ Recorder (Recorder, logger_),
+ WithPriority (WithPriority, priority),
+ cfilter,
+ cmapWithPrio,
+ makeDefaultStderrRecorder)
+import qualified FuzzySearch
+import GHC.Stack (emptyCallStack)
+import qualified HieDbRetry
import Ide.PluginUtils (pluginDescToIdePlugins)
import Ide.Types
import qualified Language.LSP.Types as LSP
@@ -120,19 +133,14 @@ import Test.Tasty.Ingredients.Rerun
import Test.Tasty.QuickCheck
import Text.Printf (printf)
import Text.Regex.TDFA ((=~))
-import qualified HieDbRetry
-import Development.IDE.Types.Logger (WithPriority(WithPriority, priority), Priority (Debug), cmapWithPrio, Recorder (Recorder, logger_), makeDefaultStderrRecorder, cfilter, LoggingColumn (PriorityColumn, DataColumn), Logger (Logger), Pretty (pretty))
-import Data.Function ((&))
-import GHC.Stack (emptyCallStack)
-import qualified FuzzySearch
-data Log
- = LogGhcIde Ghcide.Log
+data Log
+ = LogGhcIde Ghcide.Log
| LogIDEMain IDE.Log
instance Pretty Log where
pretty = \case
- LogGhcIde log -> pretty log
+ LogGhcIde log -> pretty log
LogIDEMain log -> pretty log
-- | Wait for the next progress begin step
@@ -2411,7 +2419,7 @@ insertNewDefinitionTests = testGroup "insert new definition actions"
liftIO $ contentAfterAction @?= T.unlines (txtB ++
[ ""
, "select :: [Bool] -> Bool"
- , "select = error \"not implemented\""
+ , "select = _"
]
++ txtB')
, testSession "define a hole" $ do
@@ -2438,9 +2446,61 @@ insertNewDefinitionTests = testGroup "insert new definition actions"
,"foo False = False"
, ""
, "select :: [Bool] -> Bool"
- , "select = error \"not implemented\""
+ , "select = _"
]
++ txtB')
+ , testSession "insert new function definition - Haddock comments" $ do
+ let start = ["foo :: Int -> Bool"
+ , "foo x = select (x + 1)"
+ , ""
+ , "-- | This is a haddock comment"
+ , "haddock :: Int -> Int"
+ , "haddock = undefined"
+ ]
+ let expected = ["foo :: Int -> Bool"
+ , "foo x = select (x + 1)"
+ , ""
+ , "select :: Int -> Bool"
+ , "select = _"
+ , ""
+ , "-- | This is a haddock comment"
+ , "haddock :: Int -> Int"
+ , "haddock = undefined"]
+ docB <- createDoc "ModuleB.hs" "haskell" (T.unlines start)
+ _ <- waitForDiagnostics
+ InR action@CodeAction { _title = actionTitle } : _
+ <- sortOn (\(InR CodeAction{_title=x}) -> x) <$>
+ getCodeActions docB (R 1 0 0 50)
+ liftIO $ actionTitle @?= "Define select :: Int -> Bool"
+ executeCodeAction action
+ contentAfterAction <- documentContents docB
+ liftIO $ contentAfterAction @?= T.unlines expected
+ , testSession "insert new function definition - normal comments" $ do
+ let start = ["foo :: Int -> Bool"
+ , "foo x = select (x + 1)"
+ , ""
+ , "-- This is a normal comment"
+ , "normal :: Int -> Int"
+ , "normal = undefined"
+ ]
+ let expected = ["foo :: Int -> Bool"
+ , "foo x = select (x + 1)"
+ , ""
+ , "select :: Int -> Bool"
+ , "select = _"
+ , ""
+ , "-- This is a normal comment"
+ , "normal :: Int -> Int"
+ , "normal = undefined"]
+ docB <- createDoc "ModuleB.hs" "haskell" (T.unlines start)
+ _ <- waitForDiagnostics
+ InR action@CodeAction { _title = actionTitle } : _
+ <- sortOn (\(InR CodeAction{_title=x}) -> x) <$>
+ getCodeActions docB (R 1 0 0 50)
+ liftIO $ actionTitle @?= "Define select :: Int -> Bool"
+ executeCodeAction action
+ contentAfterAction <- documentContents docB
+ liftIO $ contentAfterAction @?= T.unlines expected
]
@@ -5613,7 +5673,7 @@ bootTests = testGroup "boot"
hoverResponseOrReadyMessage <- skipManyTill anyMessage ((Left <$> parseHoverResponse) <|> (Right <$> parseReadyMessage))
_ <- skipManyTill anyMessage $
case hoverResponseOrReadyMessage of
- Left _ -> void parseReadyMessage
+ Left _ -> void parseReadyMessage
Right _ -> void parseHoverResponse
closeDoc cDoc
cdoc <- createDoc cPath "haskell" cSource
From 7393e48a638bbc2890d40c4a94382d721fc4995d Mon Sep 17 00:00:00 2001
From: Nick Suchecki <nicksuchecki@gmail.com>
Date: Sun, 27 Feb 2022 11:34:10 -0500
Subject: [PATCH 2/2] Revert whitespace
---
ghcide/src/Development/IDE/Plugin/CodeAction.hs | 2 --
1 file changed, 2 deletions(-)
diff --git a/ghcide/src/Development/IDE/Plugin/CodeAction.hs b/ghcide/src/Development/IDE/Plugin/CodeAction.hs
index 7d10ff105b..c3339d04de 100644
--- a/ghcide/src/Development/IDE/Plugin/CodeAction.hs
+++ b/ghcide/src/Development/IDE/Plugin/CodeAction.hs
@@ -64,8 +64,6 @@ import qualified GHC.LanguageExtensions as Lang
import Ide.PluginUtils (subRange)
import Ide.Types
import qualified Language.LSP.Server as LSP
-
-
import Language.LSP.Types (CodeAction (..),
CodeActionContext (CodeActionContext, _diagnostics),
CodeActionKind (CodeActionQuickFix, CodeActionUnknown),