Inline code action

Author: pepeiborra

ghcide/src/Development/IDE/Core/Actions.hs

@@ -10,6 +10,7 @@ module Development.IDE.Core.Actions
 , useNoFileE
 , usesE
 , workspaceSymbols
+, lookupMod
 ) where
 
 import           Control.Monad.Reader

ghcide/src/Development/IDE/Core/Shake.hs

@@ -982,7 +982,10 @@ usesWithStale_ key files = do
 --
 -- Run via 'runIdeAction'.
 newtype IdeAction a = IdeAction { runIdeActionT  :: (ReaderT ShakeExtras IO) a }
-    deriving newtype (MonadReader ShakeExtras, MonadIO, Functor, Applicative, Monad)
+    deriving newtype (MonadReader ShakeExtras, MonadIO, Functor, Applicative, Monad, Semigroup)
+
+-- https://hub.darcs.net/ross/transformers/issue/86
+deriving instance (Semigroup (m a)) => Semigroup (ReaderT r m a)
 
 runIdeAction :: String -> ShakeExtras -> IdeAction a -> IO a
 runIdeAction _herald s i = runReaderT (runIdeActionT i) s

ghcide/src/Development/IDE/GHC/Compat/Core.hs

@@ -447,6 +447,7 @@ module Development.IDE.GHC.Compat.Core (
     -- * Syntax re-exports
 #if MIN_VERSION_ghc(9,0,0)
     module GHC.Hs,
+    module GHC.Hs.Binds,
     module GHC.Parser,
     module GHC.Parser.Header,
     module GHC.Parser.Lexer,
@@ -786,6 +787,7 @@ import qualified Finder as GHC
 -- (until the CPP extension is actually needed).
 import GHC.LanguageExtensions.Type hiding (Cpp)
 
+import           GHC.Hs.Binds
 
 mkHomeModLocation :: DynFlags -> ModuleName -> FilePath -> IO Module.ModLocation
 #if MIN_VERSION_ghc(9,3,0)

ghcide/src/Development/IDE/Spans/AtPoint.hs

@@ -20,6 +20,8 @@ module Development.IDE.Spans.AtPoint (
   , getNamesAtPoint
   , toCurrentLocation
   , rowToLoc
+  , nameToLocation
+  , LookupModule
   ) where
 
 import           Development.IDE.GHC.Error

plugins/hls-retrie-plugin/hls-retrie-plugin.cabal

@@ -31,6 +31,7 @@ library
     , ghcide                ^>=1.9
     , hashable
     , hls-plugin-api        ^>=1.6
+    , hls-refactor-plugin
     , lsp
     , lsp-types
     , retrie                >=0.1.1.0
@@ -46,3 +47,24 @@ library
     TypeOperators
 
   ghc-options:        -Wno-unticked-promoted-constructors
+
+test-suite tests
+  if impl(ghc >= 9.3)
+    buildable: False
+  else
+    buildable: True
+  type:             exitcode-stdio-1.0
+  default-language: Haskell2010
+  hs-source-dirs:   test
+  main-is:          Main.hs
+  ghc-options:      -threaded -rtsopts -with-rtsopts=-N
+  build-depends:
+    , aeson
+    , base
+    , containers
+    , filepath
+    , hls-plugin-api
+    , hls-refactor-plugin
+    , hls-retrie-plugin
+    , hls-test-utils             ^>=1.5
+    , text

plugins/hls-retrie-plugin/src/Ide/Plugin/Retrie.hs

@@ -0,0 +1,97 @@
+{-# LANGUAGE DisambiguateRecordFields #-}
+{-# LANGUAGE NamedFieldPuns           #-}
+{-# LANGUAGE OverloadedStrings        #-}
+{-# LANGUAGE PartialTypeSignatures    #-}
+{-# LANGUAGE TypeOperators            #-}
+
+module Main (main) where
+
+import           Control.Concurrent                (threadDelay)
+import           Control.Monad                     (void)
+import           Data.Aeson
+import qualified Data.Map                          as M
+import           Data.Text                         (Text)
+import qualified Development.IDE.GHC.ExactPrint
+import qualified Development.IDE.Plugin.CodeAction as Refactor
+import           Ide.Plugin.Config
+import qualified Ide.Plugin.Retrie                 as Retrie
+import           Ide.Types                         (IdePlugins (IdePlugins))
+import           System.FilePath
+import           Test.Hls
+import           Test.Hls                          (PluginTestDescriptor)
+
+main :: IO ()
+main = defaultTestRunner tests
+
+retriePlugin :: PluginTestDescriptor a
+retriePlugin = mkPluginTestDescriptor' Retrie.descriptor "retrie"
+
+refactorPlugin :: PluginTestDescriptor Development.IDE.GHC.ExactPrint.Log
+refactorPlugin = mkPluginTestDescriptor Refactor.iePluginDescriptor "refactor"
+
+tests :: TestTree
+tests = testGroup "Retrie"
+    [ inlineThisTests
+    ]
+
+inlineThisTests :: TestTree
+inlineThisTests = testGroup "Inline this"
+    [
+        testGroup "provider" [
+            testProvider "lhs" "Identity" 4 1 ["Unfold function", "Unfold function in current file", "Fold function", "Fold function in current file"],
+            testProvider "identifier" "Identity" 4 16 ["Inline identity"],
+            testProvider "imported identifier" "Imported" 4 12 ["Inline identity"],
+            testProvider "nested where" "NestedWhere" 4 16 ["Inline identity"],
+            testProvider "nested let" "NestedLet" 6 12 ["Inline identity"],
+            testProvider "class member" "Class" 5 16 [],
+            testProvider "operator" "Operator" 4 16 ["Inline */"]
+        ],
+        testGroup "command" [
+            testCommand "top level function" "Identity" 4 16,
+            testCommand "top level function in another file" "Imported" 4 12,
+            testCommand "nested where function" "NestedWhere" 4 16,
+            testCommand "nested let function" "NestedLet" 6 12,
+            testCommand "operator" "Operator" 4 16
+        ]
+    ]
+
+
+testProvider title file line row expected = testCase title $ runWithRetrie $ do
+    adoc <- openDoc (file <.> "hs") "haskell"
+    waitForTypecheck adoc
+    let position = Position line row
+    codeActions <- getCodeActions adoc $ Range position position
+    liftIO $ map codeActionTitle codeActions @?= map Just expected
+
+testCommand :: TestName -> FilePath -> UInt -> UInt -> TestTree
+testCommand title file row col = goldenWithRetrie title file $ \adoc -> do
+    waitForTypecheck adoc
+    let p = Position row col
+    codeActions <- getCodeActions adoc $ Range p p
+    case codeActions of
+        [InR ca] -> do
+            executeCodeAction ca
+            void $ skipManyTill anyMessage $ getDocumentEdit adoc
+        [] -> error "No code actions found"
+
+codeActionTitle :: (Command |? CodeAction) -> Maybe Text
+codeActionTitle (InR CodeAction {_title}) = Just _title
+codeActionTitle _                         = Nothing
+
+goldenWithRetrie :: TestName -> FilePath -> (TextDocumentIdentifier -> Session ()) -> TestTree
+goldenWithRetrie title path act =
+    goldenWithHaskellDoc testPlugins title testDataDir path "expected" "hs" $ \doc -> do
+        sendConfigurationChanged $ toJSON $
+            def { plugins = M.fromList [("retrie", def)] }
+        act doc
+
+runWithRetrie :: Session a -> IO a
+runWithRetrie = runSessionWithServer testPlugins testDataDir
+
+testPlugins :: PluginTestDescriptor _
+testPlugins =
+    retriePlugin <>
+    refactorPlugin  -- needed for the GetAnnotatedParsedSource rule
+
+testDataDir :: FilePath
+testDataDir = "test" </> "testdata"

plugins/hls-retrie-plugin/test/Main.hs

@@ -0,0 +1,7 @@
+module Class where
+
+class Identity x where
+    identity :: x -> x
+    identity x = x
+
+function x = identity x

plugins/hls-retrie-plugin/test/testdata/Class.hs

@@ -0,0 +1,5 @@
+module Identity where
+
+identity x = x
+
+function x = x

plugins/hls-retrie-plugin/test/testdata/Identity.expected.hs

@@ -0,0 +1,5 @@
+module Identity where
+
+identity x = x
+
+function x = identity x

plugins/hls-retrie-plugin/test/testdata/Identity.hs

@@ -0,0 +1,5 @@
+module Imported where
+
+import Identity
+
+f x = x

plugins/hls-retrie-plugin/test/testdata/Imported.expected.hs

@@ -0,0 +1,5 @@
+module Imported where
+
+import Identity
+
+f x = identity x

plugins/hls-retrie-plugin/test/testdata/Imported.hs

@@ -0,0 +1,7 @@
+module Nested where
+
+
+
+function x = x
+  where
+    identity x = x

plugins/hls-retrie-plugin/test/testdata/Nested.expected.hs

@@ -0,0 +1,7 @@
+module NestedLet where
+
+
+
+function x =
+    let identity x = x
+    in x

plugins/hls-retrie-plugin/test/testdata/NestedLet.expected.hs

@@ -0,0 +1,7 @@
+module NestedLet where
+
+
+
+function x =
+    let identity x = x
+    in identity x

plugins/hls-retrie-plugin/test/testdata/NestedLet.hs

@@ -0,0 +1,10 @@
+
+module NestedNested where
+
+
+
+function x = meme x
+  where
+    meme x = identity x
+    identity x = x
+

plugins/hls-retrie-plugin/test/testdata/NestedNested.hs

@@ -0,0 +1,7 @@
+module NestedWhere where
+
+
+
+function x = x
+  where
+    identity x = x

plugins/hls-retrie-plugin/test/testdata/NestedWhere.expected.hs

@@ -0,0 +1,7 @@
+module NestedWhere where
+
+
+
+function x = identity x
+  where
+    identity x = x

plugins/hls-retrie-plugin/test/testdata/NestedWhere.hs

@@ -0,0 +1,5 @@
+module Operator where
+
+x */ y = x
+
+function x = x

plugins/hls-retrie-plugin/test/testdata/Operator.expected.hs

@@ -0,0 +1,5 @@
+module Operator where
+
+x */ y = x
+
+function x = x */ ()

plugins/hls-retrie-plugin/test/testdata/Operator.hs

@@ -0,0 +1,4 @@
+cradle:
+  bios:
+    shell: |
+      find . -name "*.hs" > $HIE_BIOS_OUTPUT

plugins/hls-retrie-plugin/test/testdata/hie.yaml

@@ -137,3 +137,4 @@ runLspMode recorder ghcideArgs@GhcideArguments{..} idePlugins = withTelemetryLog
         let defOptions = IDEMain.argsIdeOptions args config sessionLoader
         in defOptions { Ghcide.optShakeProfiling = argsShakeProfiling }
       }
+

src/Ide/Main.hs

@@ -7,6 +7,7 @@
 -- and the current project's version
 module Ide.Version where
 
+
 import           Data.Maybe                    (listToMaybe)
 import           Data.Version
 import           GitHash                       (giCommitCount, tGitInfoCwdTry)