Handle file rename in .cabal file

.hlint.yaml

@@ -215,6 +215,7 @@
     - Development.IDE.Graph.Internal.Profile
     - Development.IDE.Graph.Internal.Rules
     - CodeLensTests #Previously part of GHCIDE Main tests
+    - Test.Hls.Util # Used in `willRenameFile`: This function is only here temporarily as we are planning to upstream to lsp-test.
 
   - name: "Data.Map.!"
     within: []

haskell-language-server.cabal

@@ -261,6 +261,7 @@ library hls-cabal-plugin
     Ide.Plugin.Cabal.CabalAdd.Command
     Ide.Plugin.Cabal.CabalAdd.CodeAction
     Ide.Plugin.Cabal.CabalAdd.Types
+    Ide.Plugin.Cabal.CabalAdd.Rename
     Ide.Plugin.Cabal.Orphans
     Ide.Plugin.Cabal.Outline
     Ide.Plugin.Cabal.Parse
@@ -309,6 +310,7 @@ test-suite hls-cabal-plugin-tests
     Definition
     Outline
     Utils
+    Workspace
   build-depends:
     , bytestring
     , Cabal-syntax          >= 3.7

hls-test-utils/src/Test/Hls/Util.hs

@@ -2,6 +2,7 @@
 {-# LANGUAGE DataKinds             #-}
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE GADTs                 #-}
+{-# LANGUAGE LambdaCase            #-}
 {-# LANGUAGE OverloadedStrings     #-}
 module Test.Hls.Util
   (  -- * Test Capabilities
@@ -37,6 +38,7 @@ module Test.Hls.Util
     , inspectCommand
     , inspectDiagnostic
     , inspectDiagnosticAny
+    , renameFile
     , waitForDiagnosticsFrom
     , waitForDiagnosticsFromSource
     , waitForDiagnosticsFromSourceWithTimeout
@@ -52,7 +54,8 @@ module Test.Hls.Util
 where
 
 import           Control.Applicative.Combinators          (skipManyTill, (<|>))
-import           Control.Exception                        (catch, throwIO)
+import           Control.Exception                        (catch, throw,
+                                                           throwIO)
 import           Control.Lens                             (_Just, (&), (.~),
                                                            (?~), (^.))
 import           Control.Monad
@@ -69,7 +72,7 @@ import qualified Language.LSP.Protocol.Lens               as L
 import           Language.LSP.Protocol.Message
 import           Language.LSP.Protocol.Types
 import qualified Language.LSP.Test                        as Test
-import           System.Directory
+import qualified System.Directory                         as Directory
 import           System.FilePath
 import           System.Info.Extra                        (isMac, isWindows)
 import qualified System.IO.Extra
@@ -80,12 +83,16 @@ import           Test.Tasty.ExpectedFailure               (expectFailBecause,
                                                            ignoreTestBecause)
 import           Test.Tasty.HUnit                         (assertFailure)
 
+import           Data.Foldable                            (traverse_)
 import qualified Data.List                                as List
+import qualified Data.Map                                 as Map
+import           Data.Maybe                               (fromJust)
 import           Data.String.Interpolate                  (__i)
 import qualified Data.Text.Internal.Search                as T
 import qualified Data.Text.Utf16.Rope.Mixed               as Rope
 import           Development.IDE.Plugin.Completions.Logic (getCompletionPrefixFromRope)
 import           Development.IDE.Plugin.Completions.Types (PosPrefixInfo (..))
+import qualified Language.LSP.Server                      as LSP
 
 noLiteralCaps :: ClientCapabilities
 noLiteralCaps = def & L.textDocument ?~ textDocumentCaps
@@ -187,7 +194,7 @@ onlyRunForGhcVersions vers =
 withCurrentDirectoryInTmp :: FilePath -> IO a -> IO a
 withCurrentDirectoryInTmp dir f =
   withTempCopy ignored dir $ \newDir ->
-    withCurrentDirectory newDir f
+    Directory.withCurrentDirectory newDir f
   where
     ignored = ["dist", "dist-newstyle", ".stack-work"]
 
@@ -200,7 +207,7 @@ withCurrentDirectoryInTmp dir f =
 withCurrentDirectoryInTmp' :: [FilePath] -> FilePath -> IO a -> IO a
 withCurrentDirectoryInTmp' ignored dir f =
   withTempCopy ignored dir $ \newDir ->
-    withCurrentDirectory newDir f
+    Directory.withCurrentDirectory newDir f
 
 -- | Example call: @withTempCopy ignored src f@
 --
@@ -219,15 +226,15 @@ withTempCopy ignored srcDir f = do
 -- that are listed in 'ignored'.
 copyDir :: [FilePath] -> FilePath -> FilePath -> IO ()
 copyDir ignored src dst = do
-  cnts <- listDirectory src
+  cnts <- Directory.listDirectory src
   forM_ cnts $ \file -> do
     unless (file `elem` ignored) $ do
       let srcFp = src </> file
           dstFp = dst </> file
-      isDir <- doesDirectoryExist srcFp
+      isDir <- Directory.doesDirectoryExist srcFp
       if isDir
-        then createDirectory dstFp >> copyDir ignored srcFp dstFp
-        else copyFile srcFp dstFp
+        then Directory.createDirectory dstFp >> copyDir ignored srcFp dstFp
+        else Directory.copyFile srcFp dstFp
 
 fromAction :: (Command |? CodeAction) -> CodeAction
 fromAction (InR action) = action
@@ -335,6 +342,92 @@ failIfSessionTimeout action = action `catch` errorHandler
           errorHandler e@(Test.Timeout _) = assertFailure $ show e
           errorHandler e                  = throwIO e
 
+-- ---------------------------------------------------------------------
+
+-- | Simulate the client action of renaming a file
+-- This consists of sending a `WillRenameFiles` request renaming the file from `from` to `to`,
+-- and applying the returned `WorkspaceEdit` changes and actually renaming the file.
+-- Finally sends a `DidRenameFile` notification to the server.
+renameFile :: TextDocumentIdentifier -> TextDocumentIdentifier -> Test.Session ()
+renameFile from to = do
+    willRenameFile from to >>= \case
+        InL we -> do
+            case LSP.reverseSortEdit we of
+                (WorkspaceEdit (Just e) _ _) ->
+                    traverse_
+                        ( \(uri, edits) ->
+                            -- TODO: once we move this to lsp, we can simply send an ApplyWorkspaceEdit
+                            -- request directly and the server will handle it for us
+                            traverse (Test.applyEdit (TextDocumentIdentifier uri)) edits
+                        )
+                        (Map.assocs e)
+                (WorkspaceEdit _ (Just docChanges) _) -> do
+                    traverse_
+                        ( \case
+                            InL edit ->
+                                traverse_
+                                    (\e ->
+                                        Test.applyEdit
+                                            (TextDocumentIdentifier $ edit ^. L.textDocument . L.uri)
+                                            $ mkTextEdit e
+                                    )
+                                    (edit ^. L.edits)
+                            InR unsupported ->
+                                error $ "renameFile: Unsupported WorkspaceEdit " <> (show unsupported)
+                        )
+                        docChanges
+                _ -> pure ()
+        _ -> pure ()
+    -- We are using the below two operations in place of renameFile,
+    -- due to a potential race condition on Windows.
+    liftIO $ Directory.copyFileWithMetadata (getFilePath from) (getFilePath to)
+    liftIO $ Directory.removeFile $ getFilePath from
+    didRenameFile from to
+    where
+        getFilePath :: TextDocumentIdentifier -> FilePath
+        getFilePath tId =
+            case uriToFilePath uri of
+                Just fp -> fp
+                Nothing -> error "Failed to parse uri " <> show uri <> " to filepath"
+            where
+                uri = tId ^. L.uri
+
+        mkTextEdit :: TextEdit |? AnnotatedTextEdit -> TextEdit
+        mkTextEdit (InL e)   = e
+        mkTextEdit (InR ate) =
+            TextEdit (ate ^. L.range) (ate ^. L.newText)
+
+-- | Sends a WillRenameFiles notification to the server and returns the edit the server produces
+-- In case the server returns an error, throws an error as well.
+willRenameFile :: TextDocumentIdentifier -> TextDocumentIdentifier -> Test.Session (WorkspaceEdit |? Null)
+willRenameFile from to = do
+  rsp <- Test.request
+    SMethod_WorkspaceWillRenameFiles
+        (
+            RenameFilesParams [FileRename (docIdToText from) (docIdToText to)]
+        )
+
+  case rsp ^. L.result of
+    Right edit -> return edit
+    -- Todo: When this function is upstreamed to lsp-test,
+    -- remove this module from the fromJust entry in `.hlint.yaml`.
+    Left error -> throw (Test.UnexpectedResponseError (fromJust $ rsp ^. L.id) error)
+
+-- | Sends a DidRenameFile Notification to the server
+-- Currently the server does not handle this notification,
+-- but the plan is to reload the session on rename.
+didRenameFile :: TextDocumentIdentifier -> TextDocumentIdentifier -> Test.Session ()
+didRenameFile from to =
+    Test.sendNotification
+        SMethod_WorkspaceDidRenameFiles
+        ( RenameFilesParams
+            [FileRename (docIdToText from) (docIdToText to)
+            ]
+        )
+
+docIdToText :: TextDocumentIdentifier -> T.Text
+docIdToText tdi = getUri $ tdi ^. L.uri
+
 -- ---------------------------------------------------------------------
 getCompletionByLabel :: MonadIO m => T.Text -> [CompletionItem] -> m CompletionItem
 getCompletionByLabel desiredLabel compls =
@@ -348,7 +441,7 @@ getCompletionByLabel desiredLabel compls =
 -- Run with a canonicalized temp dir
 withCanonicalTempDir :: (FilePath -> IO a) -> IO a
 withCanonicalTempDir f = System.IO.Extra.withTempDir $ \dir -> do
-  dir' <- canonicalizePath dir
+  dir' <- Directory.canonicalizePath dir
   f dir'
 
 -- ----------------------------------------------------------------------------

plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal.hs

@@ -6,20 +6,25 @@
 
 module Ide.Plugin.Cabal (descriptor, haskellInteractionDescriptor, Log (..)) where
 
+import           Control.Applicative                           ((<|>))
 import           Control.Lens                                  ((^.))
+import           Control.Monad.Except                          (runExceptT)
 import           Control.Monad.Extra
 import           Control.Monad.IO.Class
 import           Control.Monad.Trans.Class                     (lift)
+import           Control.Monad.Trans.Except                    (ExceptT)
 import           Control.Monad.Trans.Maybe                     (runMaybeT)
 import           Data.HashMap.Strict                           (HashMap)
 import qualified Data.List                                     as List
+import qualified Data.Map.Strict                               as Map
 import qualified Data.Maybe                                    as Maybe
 import qualified Data.Text                                     ()
 import qualified Data.Text                                     as T
 import           Development.IDE                               as D
 import           Development.IDE.Core.FileStore                (getVersionedTextDoc)
 import           Development.IDE.Core.PluginUtils
 import           Development.IDE.Core.Shake                    (restartShakeSession)
+import qualified Development.IDE.Core.Shake                    as Shake
 import           Development.IDE.Graph                         (Key)
 import           Development.IDE.LSP.HoverDefinition           (foundHover)
 import qualified Development.IDE.Plugin.Completions.Logic      as Ghcide
@@ -33,6 +38,7 @@ import           Distribution.PackageDescription.Configuration (flattenPackageDe
 import qualified Distribution.Parsec.Position                  as Syntax
 import qualified Ide.Plugin.Cabal.CabalAdd.CodeAction          as CabalAdd
 import qualified Ide.Plugin.Cabal.CabalAdd.Command             as CabalAdd
+import qualified Ide.Plugin.Cabal.CabalAdd.Rename              as Rename
 import           Ide.Plugin.Cabal.Completion.CabalFields       as CabalFields
 import qualified Ide.Plugin.Cabal.Completion.Completer.Types   as CompleterTypes
 import qualified Ide.Plugin.Cabal.Completion.Completions       as Completions
@@ -70,7 +76,11 @@ data Log
   | LogCompletionContext Types.Context Position
   | LogCompletions Types.Log
   | LogCabalAdd CabalAdd.Log
-  deriving (Show)
+  | LogDidRename Rename.Log
+  | LogShake Shake.Log
+  | LogSessionRestart
+  | LogNoCabalFile FilePath
+  | LogCabalRenameFailed T.Text PluginError
 
 instance Pretty Log where
   pretty = \case
@@ -95,6 +105,11 @@ instance Pretty Log where
         <+> pretty position
     LogCompletions logs -> pretty logs
     LogCabalAdd logs -> pretty logs
+    LogDidRename logs -> pretty logs
+    LogSessionRestart -> "Restarting shake session globally"
+    LogShake logs -> pretty logs
+    LogNoCabalFile file -> "Cannot find responsible cabal file for" <+> pretty file
+    LogCabalRenameFailed file err -> "Rename of file" <+> pretty file <+> "failed with error:" <+> pretty err
 
 {- | Some actions in cabal files can be triggered from haskell files.
 This descriptor allows us to hook into the diagnostics of haskell source files and
@@ -128,6 +143,7 @@ descriptor recorder plId =
           , mkPluginHandler LSP.SMethod_TextDocumentCodeAction $ fieldSuggestCodeAction recorder
           , mkPluginHandler LSP.SMethod_TextDocumentDefinition gotoDefinition
           , mkPluginHandler LSP.SMethod_TextDocumentHover hover
+          , mkPluginHandler LSP.SMethod_WorkspaceWillRenameFiles $ renameModulesHandler recorder
           ]
     , pluginNotificationHandlers =
         mconcat
@@ -165,7 +181,6 @@ descriptor recorder plId =
   log' = logWith recorder
   ruleRecorder = cmapWithPrio LogRule recorder
   ofInterestRecorder = cmapWithPrio LogOfInterest recorder
-
   whenUriFile :: Uri -> (NormalizedFilePath -> IO ()) -> IO ()
   whenUriFile uri act = whenJust (uriToFilePath uri) $ act . toNormalizedFilePath'
 
@@ -300,6 +315,38 @@ cabalAddModuleCodeAction recorder state plId (CodeActionParams _ _ (TextDocument
             pure $ InL $ fmap InR actions
     Nothing -> pure $ InL []
 
+renameModulesHandler :: Recorder (WithPriority Log) -> PluginMethodHandler IdeState LSP.Method_WorkspaceWillRenameFiles
+renameModulesHandler recorder ideState _plId (RenameFilesParams renames) = do
+  renamedEdits <- traverse (renameModuleHelper recorder ideState) renames
+  pure $ InL $ List.foldl' combineTextEdits (WorkspaceEdit mempty mempty mempty) renamedEdits
+
+renameModuleHelper :: Recorder (WithPriority Log) -> IdeState -> FileRename -> ExceptT PluginError (HandlerM Config) WorkspaceEdit
+renameModuleHelper recorder ideState (FileRename oldUri newUri) = do
+    caps <- lift pluginGetClientCapabilities
+    renameResult <- runExceptT $ do
+      oldHaskellFilePath <- uriToFilePathE $ Uri oldUri
+      newHaskellFilePath <- uriToFilePathE $ Uri newUri
+      mbCabalFile <- liftIO $ CabalAdd.findResponsibleCabalFile oldHaskellFilePath
+      case mbCabalFile of
+          Nothing -> do
+            logWith recorder Debug $ LogNoCabalFile oldHaskellFilePath
+            pure mempty
+          Just cabalFilePath ->
+            Rename.renameHandler
+              (cmapWithPrio LogDidRename recorder)
+              ideState
+              caps
+              oldHaskellFilePath
+              newHaskellFilePath
+              cabalFilePath
+              ideState
+    case renameResult of
+      Left err -> do
+        logWith recorder Debug $ LogCabalRenameFailed oldUri err
+        pure mempty
+      Right edit -> do
+        pure edit
+
 {- | Handler for hover messages.
 
 If the cursor is hovering on a dependency, add a documentation link to that dependency.
@@ -410,3 +457,14 @@ computeCompletionsAt recorder ide prefInfo fp fields matcher = do
   pos = Types.completionCursorPosition prefInfo
   context fields = Completions.getContext completerRecorder prefInfo fields
   completerRecorder = cmapWithPrio LogCompletions recorder
+
+combineTextEdits :: WorkspaceEdit  -> WorkspaceEdit -> WorkspaceEdit
+combineTextEdits (WorkspaceEdit c1 dc1 ca1) (WorkspaceEdit c2 dc2 ca2) =
+  WorkspaceEdit c dc ca
+ where
+  c = liftA2 (Map.unionWith (<>)) c1 c2 <|> c1 <|> c2
+  dc = dc1 <> dc2
+  -- We know this might result in information loss due to the monad instance of map,
+  -- but we do not expect our use of workspacedit combination to contain two changeAnnotations
+  -- for the same edit.
+  ca = ca1 <> ca2

plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/CabalAdd/CodeAction.hs

@@ -248,7 +248,7 @@ addDependencySuggestCodeAction ::
   GenericPackageDescription ->
   IO [J.CodeAction]
 addDependencySuggestCodeAction plId verTxtDocId suggestions haskellFilePath cabalFilePath gpd = do
-  buildTargets <- liftIO $ getBuildTargets gpd cabalFilePath haskellFilePath
+  buildTargets <- liftIO $ getBuildTargets (flattenPackageDescription gpd) cabalFilePath haskellFilePath
   case buildTargets of
     -- If there are no build targets found, run the `cabal-add` command with default behaviour
     [] -> pure $ mkCodeActionForDependency cabalFilePath Nothing <$> suggestions
@@ -267,17 +267,6 @@ addDependencySuggestCodeAction plId verTxtDocId suggestions haskellFilePath caba
   -}
   buildTargetToStringRepr target = render $ CabalPretty.pretty $ buildTargetComponentName target
 
-  {- | Finds the build targets that are used in `cabal-add`.
-   Note the unorthodox usage of `readBuildTargets`:
-   If the relative path to the haskell file is provided,
-   `readBuildTargets` will return the build targets, this
-   module is mentioned in (either exposed-modules or other-modules).
-  -}
-  getBuildTargets :: GenericPackageDescription -> FilePath -> FilePath -> IO [BuildTarget]
-  getBuildTargets gpd cabalFilePath haskellFilePath = do
-    let haskellFileRelativePath = makeRelative (dropFileName cabalFilePath) haskellFilePath
-    readBuildTargets (verboseNoStderr silent) (flattenPackageDescription gpd) [haskellFileRelativePath]
-
   mkCodeActionForDependency :: FilePath -> Maybe String -> (T.Text, T.Text) -> J.CodeAction
   mkCodeActionForDependency cabalFilePath target (suggestedDep, suggestedVersion) =
     let
@@ -300,6 +289,17 @@ addDependencySuggestCodeAction plId verTxtDocId suggestions haskellFilePath caba
      in
       J.CodeAction title (Just CodeActionKind_QuickFix) (Just []) Nothing Nothing Nothing (Just command) Nothing
 
+{- | Finds the build targets that are used in `cabal-add`.
+  Note the unorthodox usage of `readBuildTargets`:
+  If the relative path to the haskell file is provided,
+  `readBuildTargets` will return the build targets, this
+  module is mentioned in (either exposed-modules or other-modules).
+-}
+getBuildTargets :: PackageDescription -> FilePath -> FilePath -> IO [BuildTarget]
+getBuildTargets pd cabalFilePath haskellFilePath = do
+  let haskellFileRelativePath = makeRelative (dropFileName cabalFilePath) haskellFilePath
+  readBuildTargets (verboseNoStderr silent) pd [haskellFileRelativePath]
+
 {- | Gives a mentioned number of @(dependency, version)@ pairs
 found in the "hidden package" diagnostic message.