Merge branch 'master' into importsfix

Author: jneira

.github/workflows/test.yml

@@ -208,3 +208,7 @@ jobs:
       - if: ${{ needs.pre_job.outputs.should_skip != 'true' && matrix.test}}
         name: Test hls-call-hierarchy-plugin test suite
         run: cabal test hls-call-hierarchy-plugin --test-options="-j1 --rerun-update" || cabal test hls-call-hierarchy-plugin --test-options="-j1 --rerun" || LSP_TEST_LOG_COLOR=0 LSP_TEST_LOG_MESSAGES=true LSP_TEST_LOG_STDERR=true cabal test hls-call-hierarchy-plugin --test-options="-j1 --rerun"
+
+      - if: ${{ needs.pre_job.outputs.should_skip != 'true' && matrix.test}}
+        name: Test hls-rename-plugin test suite
+        run: cabal test hls-rename-plugin --test-options="-j1 --rerun-update" || cabal test hls-rename-plugin --test-options="-j1 --rerun" || LSP_TEST_LOG_COLOR=0 LSP_TEST_LOG_MESSAGES=true LSP_TEST_LOG_STDERR=true cabal test hls-rename-plugin --test-options="-j1 --rerun"

cabal-ghc901.project

@@ -15,6 +15,7 @@ packages:
          ./plugins/hls-explicit-imports-plugin
          ./plugins/hls-refine-imports-plugin
          ./plugins/hls-hlint-plugin
+         ./plugins/hls-rename-plugin
          ./plugins/hls-retrie-plugin
          ./plugins/hls-haddock-comments-plugin
         --  ./plugins/hls-splice-plugin

cabal.project

@@ -15,6 +15,7 @@ packages:
          ./plugins/hls-explicit-imports-plugin
          ./plugins/hls-refine-imports-plugin
          ./plugins/hls-hlint-plugin
+         ./plugins/hls-rename-plugin
          ./plugins/hls-retrie-plugin
          ./plugins/hls-haddock-comments-plugin
          ./plugins/hls-splice-plugin

exe/Plugins.hs

@@ -37,6 +37,10 @@ import           Ide.Plugin.ExplicitImports        as ExplicitImports
 import           Ide.Plugin.RefineImports          as RefineImports
 #endif
 
+#if rename
+import           Ide.Plugin.Rename                 as Rename
+#endif
+
 #if retrie
 import           Ide.Plugin.Retrie                 as Retrie
 #endif
@@ -115,6 +119,9 @@ idePlugins includeExamples = pluginDescToIdePlugins allPlugins
 #if stylishHaskell
       StylishHaskell.descriptor "stylish-haskell" :
 #endif
+#if rename
+      Rename.descriptor "rename" :
+#endif
 #if retrie
       Retrie.descriptor "retrie" :
 #endif

ghcide/bench/lib/Experiments.hs

@@ -74,10 +74,10 @@ experiments =
         isJust <$> getHover doc (fromJust identifierP),
       ---------------------------------------------------------------------------------------
       bench "edit" $ \docs -> do
-        forM_ docs $ \DocumentPositions{..} ->
+        forM_ docs $ \DocumentPositions{..} -> do
           changeDoc doc [charEdit stringLiteralP]
-        -- wait for a fresh build start
-        waitForProgressStart
+          -- wait for a fresh build start
+          waitForProgressStart
         -- wait for the build to be finished
         waitForProgressDone
         return True,
@@ -121,8 +121,9 @@ experiments =
         ( \docs -> do
             unless (any (isJust . identifierP) docs) $
                 error "None of the example modules is suitable for this experiment"
-            forM_ docs $ \DocumentPositions{..} ->
+            forM_ docs $ \DocumentPositions{..} -> do
                 forM_ identifierP $ \p -> changeDoc doc [charEdit p]
+                waitForProgressStart
             waitForProgressDone
         )
         ( \docs -> not . null . catMaybes <$> forM docs (\DocumentPositions{..} ->
@@ -139,8 +140,9 @@ experiments =
                 forM_ identifierP $ \p -> changeDoc doc [charEdit p]
         )
         ( \docs -> do
-            forM_ docs $ \DocumentPositions{..} ->
+            forM_ docs $ \DocumentPositions{..} -> do
               changeDoc doc [charEdit stringLiteralP]
+              waitForProgressStart
             waitForProgressDone
             not . null . catMaybes <$> forM docs (\DocumentPositions{..} -> do
               forM identifierP $ \p ->
@@ -160,8 +162,9 @@ experiments =
             liftIO $ appendFile (fromJust $ uriToFilePath hieYamlUri) "##\n"
             sendNotification SWorkspaceDidChangeWatchedFiles $ DidChangeWatchedFilesParams $
                 List [ FileEvent hieYamlUri FcChanged ]
-            forM_ docs $ \DocumentPositions{..} ->
+            forM_ docs $ \DocumentPositions{..} -> do
               changeDoc doc [charEdit stringLiteralP]
+              waitForProgressStart
             waitForProgressDone
             not . null . catMaybes <$> forM docs (\DocumentPositions{..} -> do
               forM identifierP $ \p ->

ghcide/exe/Arguments.hs

@@ -31,12 +31,12 @@ arguments :: IdePlugins IdeState -> Parser Arguments
 arguments plugins = Arguments
       <$> optional (strOption $ long "cwd" <> metavar "DIR" <> help "Change to this directory")
       <*> switch (long "version" <> help "Show ghcide and GHC versions")
-      <*> optional (strOption $ long "shake-profiling" <> metavar "DIR" <> help "Dump profiling reports to this directory")
+      <*> optional (strOption $ long "shake-profiling" <> metavar "DIR" <> help "Dump profiling reports to this directory (env var: GHCIDE_BUILD_PROFILING)")
       <*> switch (long "ot-memory-profiling" <> help "Record OpenTelemetry info to the eventlog. Needs the -l RTS flag to have an effect")
       <*> switch (long "test" <> help "Enable additional lsp messages used by the testsuite")
       <*> switch (long "test-no-kick" <> help "Disable kick. Useful for testing cancellation")
       <*> option auto (short 'j' <> help "Number of threads (0: automatic)" <> metavar "NUM" <> value 0 <> showDefault)
-      <*> switch (long "verbose" <> help "Include internal events in logging output")
+      <*> switch (short 'd' <> long "verbose" <> help "Include internal events in logging output")
       <*> (commandP plugins <|> lspCommand <|> checkCommand)
       where
           checkCommand = Check <$> many (argument str (metavar "FILES/DIRS..."))

ghcide/session-loader/Development/IDE/Session.hs

@@ -501,9 +501,8 @@ cradleToOptsAndLibDir :: Show a => Cradle a -> FilePath
                       -> IO (Either [CradleError] (ComponentOptions, FilePath))
 cradleToOptsAndLibDir cradle file = do
     -- Start off by getting the session options
-    let showLine s = hPutStrLn stderr ("> " ++ s)
     hPutStrLn stderr $ "Output from setting up the cradle " <> show cradle
-    cradleRes <- runCradle (cradleOptsProg cradle) showLine file
+    cradleRes <- HieBios.getCompilerOptions file cradle
     case cradleRes of
         CradleSuccess r -> do
             -- Now get the GHC lib dir

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

@@ -12,12 +12,12 @@ module Development.IDE.Core.Service(
     getIdeOptions, getIdeOptionsIO,
     IdeState, initialise, shutdown,
     runAction,
-    writeProfile,
     getDiagnostics,
     ideLogger,
     updatePositionMapping,
     ) where
 
+import           Control.Applicative             ((<|>))
 import           Development.IDE.Core.Debouncer
 import           Development.IDE.Core.FileExists (fileExistsRules)
 import           Development.IDE.Core.OfInterest
@@ -30,6 +30,7 @@ import qualified Language.LSP.Types              as LSP
 
 import           Control.Monad
 import           Development.IDE.Core.Shake
+import           System.Environment             (lookupEnv)
 
 
 ------------------------------------------------------------
@@ -46,13 +47,17 @@ initialise :: Config
            -> HieDb
            -> IndexQueue
            -> IO IdeState
-initialise defaultConfig mainRule lspEnv logger debouncer options vfs hiedb hiedbChan =
+initialise defaultConfig mainRule lspEnv logger debouncer options vfs hiedb hiedbChan = do
+    shakeProfiling <- do
+        let fromConf = optShakeProfiling options
+        fromEnv <- lookupEnv "GHCIDE_BUILD_PROFILING"
+        return $ fromConf <|> fromEnv
     shakeOpen
         lspEnv
         defaultConfig
         logger
         debouncer
-        (optShakeProfiling options)
+        shakeProfiling
         (optReportProgress options)
         (optTesting options)
         hiedb
@@ -65,9 +70,6 @@ initialise defaultConfig mainRule lspEnv logger debouncer options vfs hiedb hied
             fileExistsRules lspEnv vfs
             mainRule
 
-writeProfile :: IdeState -> FilePath -> IO ()
-writeProfile = shakeProfile
-
 -- | Shutdown the Compiler Service.
 shutdown :: IdeState -> IO ()
 shutdown = shakeShut

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

@@ -31,7 +31,6 @@ module Development.IDE.Core.Shake(
     GetModificationTime(GetModificationTime, GetModificationTime_, missingFileDiagnostics),
     shakeOpen, shakeShut,
     shakeEnqueue,
-    shakeProfile,
     newSession,
     use, useNoFile, uses, useWithStaleFast, useWithStaleFast', delayedAction,
     FastResult(..),
@@ -550,14 +549,12 @@ shakeSessionInit IdeState{..} = do
     initSession <- newSession shakeExtras shakeDb []
     putMVar shakeSession initSession
 
-shakeProfile :: IdeState -> FilePath -> IO ()
-shakeProfile IdeState{..} = shakeProfileDatabase shakeDb
-
 shakeShut :: IdeState -> IO ()
 shakeShut IdeState{..} = withMVar shakeSession $ \runner -> do
     -- Shake gets unhappy if you try to close when there is a running
     -- request so we first abort that.
     void $ cancelShakeSession runner
+    void $ shakeDatabaseProfile shakeDb
     shakeClose
     progressStop $ progress shakeExtras
 

ghcide/src/Development/IDE/Plugin/CodeAction.hs

@@ -1529,20 +1529,21 @@ rangesForBindingImport :: ImportDecl GhcPs -> String -> [Range]
 rangesForBindingImport ImportDecl{ideclHiding = Just (False, L _ lies)} b =
     concatMap (mapMaybe srcSpanToRange . rangesForBinding' b') lies
   where
-    b' = modifyBinding b
+    b' = wrapOperatorInParens b
 rangesForBindingImport _ _ = []
 
-modifyBinding :: String -> String
-modifyBinding = wrapOperatorInParens . unqualify
-  where
-    wrapOperatorInParens x = if isAlpha (head x) then x else "(" <> x <> ")"
-    unqualify x = snd $ breakOnEnd "." x
+wrapOperatorInParens :: String -> String
+wrapOperatorInParens x =
+  case uncons x of
+    Just (h, _t) -> if isAlpha h then x else "(" <> x <> ")"
+    Nothing      -> mempty
 
 smallerRangesForBindingExport :: [LIE GhcPs] -> String -> [Range]
 smallerRangesForBindingExport lies b =
     concatMap (mapMaybe srcSpanToRange . ranges') lies
   where
-    b' = modifyBinding b
+    unqualify = snd . breakOnEnd "."
+    b' = wrapOperatorInParens . unqualify $ b
     ranges' (L _ (IEThingWith _ thing _  inners labels))
       | showSDocUnsafe (ppr thing) == b' = []
       | otherwise =

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

@@ -16,6 +16,9 @@ module Development.IDE.Spans.AtPoint (
   , computeTypeReferences
   , FOIReferences(..)
   , defRowToSymbolInfo
+  , getAstNamesAtPoint
+  , toCurrentLocation
+  , rowToLoc
   ) where
 
 import           Development.IDE.GHC.Error
@@ -90,18 +93,26 @@ foiReferencesAtPoint file pos (FOIReferences asts) =
   case HM.lookup file asts of
     Nothing -> ([],[],[])
     Just (HAR _ hf _ _ _,mapping) ->
-      let posFile = fromMaybe pos $ fromCurrentPosition mapping pos
-          names = concat $ pointCommand hf posFile (rights . M.keys . getNodeIds)
+      let names = getAstNamesAtPoint hf pos mapping
           adjustedLocs = HM.foldr go [] asts
           go (HAR _ _ rf tr _, mapping) xs = refs ++ typerefs ++ xs
             where
               refs = mapMaybe (toCurrentLocation mapping . realSrcSpanToLocation . fst)
                    $ concat $ mapMaybe (\n -> M.lookup (Right n) rf) names
               typerefs = mapMaybe (toCurrentLocation mapping . realSrcSpanToLocation)
                    $ concat $ mapMaybe (`M.lookup` tr) names
-          toCurrentLocation mapping (Location uri range) = Location uri <$> toCurrentRange mapping range
         in (names, adjustedLocs,map fromNormalizedFilePath $ HM.keys asts)
 
+getAstNamesAtPoint :: HieASTs a -> Position -> PositionMapping -> [Name]
+getAstNamesAtPoint hf pos mapping =
+  concat $ pointCommand hf posFile (rights . M.keys . getNodeIds)
+    where
+      posFile = fromMaybe pos $ fromCurrentPosition mapping pos
+
+toCurrentLocation :: PositionMapping -> Location -> Maybe Location
+toCurrentLocation mapping (Location uri range) =
+  Location uri <$> toCurrentRange mapping range
+
 referencesAtPoint
   :: MonadIO m
   => HieDb

ghcide/test/exe/Main.hs

@@ -1197,6 +1197,33 @@ removeImportTests = testGroup "remove import actions"
             , "type T = K.Type"
             ]
       liftIO $ expectedContentAfterAction @=? contentAfterAction
+  , testSession "remove unused operators whose name ends with '.'" $ do
+      let contentA = T.unlines
+            [ "module ModuleA where"
+            , "(@.) = 0 -- Must have an operator whose name ends with '.'"
+            , "a = 1 -- .. but also something else"
+            ]
+      _docA <- createDoc "ModuleA.hs" "haskell" contentA
+      let contentB = T.unlines
+            [ "{-# OPTIONS_GHC -Wunused-imports #-}"
+            , "module ModuleB where"
+            , "import ModuleA (a, (@.))"
+            , "x = a -- Must use something from module A, but not (@.)"
+            ]
+      docB <- createDoc "ModuleB.hs" "haskell" contentB
+      _ <- waitForDiagnostics
+      [InR action@CodeAction { _title = actionTitle }, _]
+          <- getCodeActions docB (Range (Position 2 0) (Position 2 5))
+      liftIO $ "Remove @. from import" @=? actionTitle
+      executeCodeAction action
+      contentAfterAction <- documentContents docB
+      let expectedContentAfterAction = T.unlines
+            [ "{-# OPTIONS_GHC -Wunused-imports #-}"
+            , "module ModuleB where"
+            , "import ModuleA (a)"
+            , "x = a -- Must use something from module A, but not (@.)"
+            ]
+      liftIO $ expectedContentAfterAction @=? contentAfterAction
   ]
 
 extendImportTests :: TestTree
@@ -3358,6 +3385,18 @@ removeExportTests = testGroup "remove export actions"
               , "import qualified Data.List as M"
               , "a :: ()"
               , "a = ()"])
+    , testSession "qualified re-export ending in '.'" $ template
+        (T.unlines
+              [ "module A ((M.@.),a) where"
+              , "import qualified Data.List as M"
+              , "a :: ()"
+              , "a = ()"])
+        "Remove ‘M.@.’ from export"
+        (Just $ T.unlines
+              [ "module A (a) where"
+              , "import qualified Data.List as M"
+              , "a :: ()"
+              , "a = ()"])
     , testSession "export module" $ template
         (T.unlines
               [ "module A (module B) where"

haskell-language-server.cabal

@@ -131,6 +131,11 @@ flag refineImports
   default:     True
   manual:      True
 
+flag rename
+  description: Enable rename plugin
+  default:     False
+  manual:      True
+
 flag retrie
   description: Enable retrie plugin
   default:     True
@@ -223,6 +228,11 @@ common refineImports
     build-depends: hls-refine-imports-plugin ^>=1.0.0.0
     cpp-options: -DrefineImports
 
+common rename
+  if flag(rename) || flag(all-plugins)
+    build-depends: hls-rename-plugin ^>= 1.0.0.0
+    cpp-options: -Drename
+
 common retrie
   if flag(retrie) || flag(all-plugins)
     build-depends: hls-retrie-plugin ^>=1.0.0.1
@@ -290,6 +300,7 @@ executable haskell-language-server
                     , eval
                     , importLens
                     , refineImports
+                    , rename
                     , retrie
                     , tactic
                     , hlint
@@ -424,7 +435,6 @@ test-suite func-test
     Highlight
     Progress
     Reference
-    Rename
     Symbol
     TypeDefinition
     Test.Hls.Command
@@ -447,6 +457,8 @@ test-suite func-test
     cpp-options: -Deval
   if flag(importLens) || flag(all-plugins)
     cpp-options: -DimportLens
+  if flag(rename) || flag(all-plugins)
+    cpp-options: -Drename
   if flag(retrie) || flag(all-plugins)
     cpp-options: -Dretrie
   if flag(tactic) || flag(all-plugins)