Get files from Shake VFS from within plugin handlers

ghcide/src/Development/IDE.hs

@@ -10,7 +10,9 @@ import           Development.IDE.Core.Actions          as X (getAtPoint,
                                                              getDefinition,
                                                              getTypeDefinition)
 import           Development.IDE.Core.FileExists       as X (getFileExists)
-import           Development.IDE.Core.FileStore        as X (getFileContents)
+import           Development.IDE.Core.FileStore        as X (getFileContents,
+                                                             getFileModTimeContents,
+                                                             getUriContents)
 import           Development.IDE.Core.IdeConfiguration as X (IdeConfiguration (..),
                                                              isWorkspaceFile)
 import           Development.IDE.Core.OfInterest       as X (getFilesOfInterestUntracked)

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

@@ -3,7 +3,10 @@
 {-# LANGUAGE TypeFamilies #-}
 
 module Development.IDE.Core.FileStore(
+    getFileModTimeContents,
     getFileContents,
+    getUriContents,
+    getVersionedTextDoc,
     setFileModified,
     setSomethingModified,
     fileStoreRules,
@@ -18,12 +21,13 @@ module Development.IDE.Core.FileStore(
     isWatchSupported,
     registerFileWatches,
     shareFilePath,
-    Log(..)
+    Log(..),
     ) where
 
 import           Control.Concurrent.STM.Stats                 (STM, atomically)
 import           Control.Concurrent.STM.TQueue                (writeTQueue)
 import           Control.Exception
+import           Control.Lens                                 ((^.))
 import           Control.Monad.Extra
 import           Control.Monad.IO.Class
 import qualified Data.Binary                                  as B
@@ -33,6 +37,7 @@ import qualified Data.HashMap.Strict                          as HashMap
 import           Data.IORef
 import qualified Data.Text                                    as T
 import qualified Data.Text                                    as Text
+import           Data.Text.Utf16.Rope.Mixed                   (Rope)
 import           Data.Time
 import           Data.Time.Clock.POSIX
 import           Development.IDE.Core.FileUtils
@@ -56,13 +61,16 @@ import           Ide.Logger                                   (Pretty (pretty),
                                                                logWith, viaShow,
                                                                (<+>))
 import qualified Ide.Logger                                   as L
-import           Ide.Plugin.Config                            (CheckParents (..),
-                                                               Config)
+import           Ide.Types
+import qualified Language.LSP.Protocol.Lens                   as L
 import           Language.LSP.Protocol.Message                (toUntypedRegistration)
 import qualified Language.LSP.Protocol.Message                as LSP
 import           Language.LSP.Protocol.Types                  (DidChangeWatchedFilesRegistrationOptions (DidChangeWatchedFilesRegistrationOptions),
                                                                FileSystemWatcher (..),
-                                                               _watchers)
+                                                               TextDocumentIdentifier (..),
+                                                               VersionedTextDocumentIdentifier (..),
+                                                               _watchers,
+                                                               uriToNormalizedFilePath)
 import qualified Language.LSP.Protocol.Types                  as LSP
 import qualified Language.LSP.Server                          as LSP
 import           Language.LSP.VFS
@@ -175,20 +183,20 @@ getFileContentsRule recorder = define (cmapWithPrio LogShake recorder) $ \GetFil
 
 getFileContentsImpl
     :: NormalizedFilePath
-    -> Action ([FileDiagnostic], Maybe (FileVersion, Maybe T.Text))
+    -> Action ([FileDiagnostic], Maybe (FileVersion, Maybe Rope))
 getFileContentsImpl file = do
     -- need to depend on modification time to introduce a dependency with Cutoff
     time <- use_ GetModificationTime file
     res <- do
         mbVirtual <- getVirtualFile file
-        pure $ virtualFileText <$> mbVirtual
+        pure $ _file_text <$> mbVirtual
     pure ([], Just (time, res))
 
 -- | Returns the modification time and the contents.
 --   For VFS paths, the modification time is the current time.
-getFileContents :: NormalizedFilePath -> Action (UTCTime, Maybe T.Text)
-getFileContents f = do
-    (fv, txt) <- use_ GetFileContents f
+getFileModTimeContents :: NormalizedFilePath -> Action (UTCTime, Maybe Rope)
+getFileModTimeContents f = do
+    (fv, contents) <- use_ GetFileContents f
     modTime <- case modificationTime fv of
       Just t -> pure t
       Nothing -> do
@@ -198,7 +206,29 @@ getFileContents f = do
           _ -> do
             posix <- getModTime $ fromNormalizedFilePath f
             pure $ posixSecondsToUTCTime posix
-    return (modTime, txt)
+    return (modTime, contents)
+
+getFileContents :: NormalizedFilePath -> Action (Maybe Rope)
+getFileContents f = snd <$> use_ GetFileContents f
+
+getUriContents :: NormalizedUri -> Action (Maybe Rope)
+getUriContents uri =
+    join <$> traverse getFileContents (uriToNormalizedFilePath uri)
+
+-- | Given a text document identifier, annotate it with the latest version.
+--
+-- Like Language.LSP.Server.Core.getVersionedTextDoc, but gets the virtual file
+-- from the Shake VFS rather than the LSP VFS.
+getVersionedTextDoc :: TextDocumentIdentifier -> Action VersionedTextDocumentIdentifier
+getVersionedTextDoc doc = do
+  let uri = doc ^. L.uri
+  mvf <-
+    maybe (pure Nothing) getVirtualFile $
+        uriToNormalizedFilePath $ toNormalizedUri uri
+  let ver = case mvf of
+        Just (VirtualFile lspver _ _) -> lspver
+        Nothing                       -> 0
+  return (VersionedTextDocumentIdentifier uri ver)
 
 fileStoreRules :: Recorder (WithPriority Log) -> (NormalizedFilePath -> Action Bool) -> Rules ()
 fileStoreRules recorder isWatched = do
@@ -303,4 +333,3 @@ shareFilePath k = unsafePerformIO $ do
           Just v  -> (km, v)
           Nothing -> (HashMap.insert k k km, k)
 {-# NOINLINE shareFilePath  #-}
-

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

@@ -23,16 +23,23 @@ module Development.IDE.Core.PluginUtils
 , toCurrentRangeE
 , toCurrentRangeMT
 , fromCurrentRangeE
-, fromCurrentRangeMT) where
+, fromCurrentRangeMT
+-- Formatting handlers
+, mkFormattingHandlers) where
 
+import           Control.Lens                         ((^.))
+import           Control.Monad.Error.Class            (MonadError (throwError))
 import           Control.Monad.Extra
 import           Control.Monad.IO.Class
 import           Control.Monad.Reader                 (runReaderT)
 import           Control.Monad.Trans.Except
 import           Control.Monad.Trans.Maybe
 import           Data.Functor.Identity
 import qualified Data.Text                            as T
+import qualified Data.Text.Utf16.Rope.Mixed           as Rope
+import           Development.IDE.Core.FileStore
 import           Development.IDE.Core.PositionMapping
+import           Development.IDE.Core.Service         (runAction)
 import           Development.IDE.Core.Shake           (IdeAction, IdeRule,
                                                        IdeState (shakeExtras),
                                                        mkDelayedAction,
@@ -44,6 +51,9 @@ import           Development.IDE.Types.Location       (NormalizedFilePath)
 import qualified Development.IDE.Types.Location       as Location
 import qualified Ide.Logger                           as Logger
 import           Ide.Plugin.Error
+import           Ide.Types
+import qualified Language.LSP.Protocol.Lens           as LSP
+import           Language.LSP.Protocol.Message        (SMethod (..))
 import qualified Language.LSP.Protocol.Types          as LSP
 
 -- ----------------------------------------------------------------------------
@@ -162,3 +172,34 @@ fromCurrentRangeE mapping = maybeToExceptT (PluginInvalidUserState "fromCurrentR
 -- |MaybeT version of `fromCurrentRange`
 fromCurrentRangeMT :: Monad m => PositionMapping -> LSP.Range -> MaybeT m LSP.Range
 fromCurrentRangeMT mapping = MaybeT . pure . fromCurrentRange mapping
+
+-- ----------------------------------------------------------------------------
+-- Formatting handlers
+-- ----------------------------------------------------------------------------
+
+-- `mkFormattingHandlers` was moved here from hls-plugin-api package so that
+-- `mkFormattingHandlers` can refer to `IdeState`. `IdeState` is defined in the
+-- ghcide package, but hls-plugin-api does not depend on ghcide, so `IdeState`
+-- is not in scope there.
+
+mkFormattingHandlers :: FormattingHandler IdeState -> PluginHandlers IdeState
+mkFormattingHandlers f = mkPluginHandler SMethod_TextDocumentFormatting ( provider SMethod_TextDocumentFormatting)
+                      <> mkPluginHandler SMethod_TextDocumentRangeFormatting (provider SMethod_TextDocumentRangeFormatting)
+  where
+    provider :: forall m. FormattingMethod m => SMethod m -> PluginMethodHandler IdeState m
+    provider m ide _pid params
+      | Just nfp <- LSP.uriToNormalizedFilePath $ LSP.toNormalizedUri uri = do
+        contentsMaybe <- liftIO $ runAction "mkFormattingHandlers" ide $ getFileContents nfp
+        case contentsMaybe of
+          Just contents -> do
+            let (typ, mtoken) = case m of
+                  SMethod_TextDocumentFormatting -> (FormatText, params ^. LSP.workDoneToken)
+                  SMethod_TextDocumentRangeFormatting -> (FormatRange (params ^. LSP.range), params ^. LSP.workDoneToken)
+                  _ -> Prelude.error "mkFormattingHandlers: impossible"
+            f ide mtoken typ (Rope.toText contents) nfp opts
+          Nothing -> throwError $ PluginInvalidParams $ T.pack $ "Formatter plugin: could not get file contents for " ++ show uri
+
+      | otherwise = throwError $ PluginInvalidParams $ T.pack $ "Formatter plugin: uriToFilePath failed for: " ++ show uri
+      where
+        uri = params ^. LSP.textDocument . LSP.uri
+        opts = params ^. LSP.options

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

@@ -35,7 +35,7 @@ import           Development.IDE.Types.KnownTargets
 import           GHC.Generics                                 (Generic)
 
 import           Data.ByteString                              (ByteString)
-import           Data.Text                                    (Text)
+import           Data.Text.Utf16.Rope.Mixed                   (Rope)
 import           Development.IDE.Import.FindImports           (ArtifactsLocation)
 import           Development.IDE.Spans.Common
 import           Development.IDE.Spans.LocalBindings
@@ -275,7 +275,7 @@ type instance RuleResult GetModIfaceFromDiskAndIndex = HiFileResult
 type instance RuleResult GetModIface = HiFileResult
 
 -- | Get the contents of a file, either dirty (if the buffer is modified) or Nothing to mean use from disk.
-type instance RuleResult GetFileContents = (FileVersion, Maybe Text)
+type instance RuleResult GetFileContents = (FileVersion, Maybe Rope)
 
 type instance RuleResult GetFileExists = Bool
 

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

@@ -91,6 +91,7 @@
 import           Data.Proxy
 import qualified Data.Text                                    as T
 import qualified Data.Text.Encoding                           as T
+import qualified Data.Text.Utf16.Rope.Mixed                   as Rope
 import           Data.Time                                    (UTCTime (..))
 import           Data.Time.Clock.POSIX                        (posixSecondsToUTCTime)
 import           Data.Tuple.Extra
@@ -99,6 +100,7 @@
 import           Development.IDE.Core.FileExists              hiding (Log,
                                                                LogShake)
 import           Development.IDE.Core.FileStore               (getFileContents,
+                                                               getFileModTimeContents,
                                                                getModTime)
 import           Development.IDE.Core.IdeConfiguration
 import           Development.IDE.Core.OfInterest              hiding (Log,
@@ -220,10 +222,10 @@
 -- TODO: return text --> return rope
 getSourceFileSource :: NormalizedFilePath -> Action BS.ByteString
 getSourceFileSource nfp = do
-    (_, msource) <- getFileContents nfp
+    msource <- getFileContents nfp
     case msource of
         Nothing     -> liftIO $ BS.readFile (fromNormalizedFilePath nfp)
-        Just source -> pure $ T.encodeUtf8 source
+        Just source -> pure $ T.encodeUtf8 $ Rope.toText source
 
 -- | Parse the contents of a haskell file.
 getParsedModule :: NormalizedFilePath -> Action (Maybe ParsedModule)
@@ -789,7 +791,7 @@
             { source_version = ver
             , old_value = m_old
             , get_file_version = use GetModificationTime_{missingFileDiagnostics = False}
             , get_linkable_hashes = \fs -> map (snd . fromJust . hirCoreFp) <$> uses_ GetModIface fs
             , regenerate = regenerateHiFile session f ms
             }
       r <- loadInterface (hscEnv session) ms linkableType recompInfo
@@ -861,10 +863,10 @@
         session' <- hscEnv <$> use_ GhcSession f
         modify_dflags <- getModifyDynFlags dynFlagsModifyGlobal
         let session = hscSetFlags (modify_dflags $ hsc_dflags session') session'
-        (modTime, mFileContent) <- getFileContents f
+        (modTime, mFileContent) <- getFileModTimeContents f
         let fp = fromNormalizedFilePath f
         modS <- liftIO $ runExceptT $
-                getModSummaryFromImports session fp modTime (textToStringBuffer <$> mFileContent)
+                getModSummaryFromImports session fp modTime (textToStringBuffer . Rope.toText <$> mFileContent)
         case modS of
             Right res -> do
                 -- Check for Template Haskell
@@ -1063,7 +1065,7 @@
             -- thus bump its modification time, forcing this rule to be rerun every time.
             exists <- liftIO $ doesFileExist obj_file
             mobj_time <- liftIO $
               if exists
               then Just <$> getModTime obj_file
               else pure Nothing
             case mobj_time of

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

@@ -157,9 +157,7 @@ import           Ide.Logger                             hiding (Priority)
 import qualified Ide.Logger                             as Logger
 import           Ide.Plugin.Config
 import qualified Ide.PluginUtils                        as HLS
-import           Ide.Types                              (IdePlugins (IdePlugins),
-                                                         PluginDescriptor (pluginId),
-                                                         PluginId)
+import           Ide.Types
 import           Language.LSP.Diagnostics
 import qualified Language.LSP.Protocol.Lens             as L
 import           Language.LSP.Protocol.Message

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

@@ -19,6 +19,7 @@ import qualified Data.HashSet                             as Set
 import           Data.Maybe
 import qualified Data.Text                                as T
 import           Development.IDE.Core.Compile
+import           Development.IDE.Core.FileStore           (getUriContents)
 import           Development.IDE.Core.PluginUtils
 import           Development.IDE.Core.PositionMapping
 import           Development.IDE.Core.RuleTypes
@@ -165,8 +166,9 @@ getCompletionsLSP ide plId
   CompletionParams{_textDocument=TextDocumentIdentifier uri
                   ,_position=position
                   ,_context=completionContext} = ExceptT $ do
-    contents <- pluginGetVirtualFile $ toNormalizedUri uri
-    fmap Right $ case (contents, uriToFilePath' uri) of
+    contentsMaybe <-
+      liftIO $ runAction "Completion" ide $ getUriContents $ toNormalizedUri uri
+    fmap Right $ case (contentsMaybe, uriToFilePath' uri) of
       (Just cnts, Just path) -> do
         let npath = toNormalizedFilePath' path
         (ideOpts, compls, moduleExports, astres) <- liftIO $ runIdeAction "Completion" (shakeExtras ide) $ do
@@ -200,7 +202,7 @@ getCompletionsLSP ide plId
             pure (opts, fmap (,pm,binds) compls, moduleExports, astres)
         case compls of
           Just (cci', parsedMod, bindMap) -> do
-            let pfix = getCompletionPrefix position cnts
+            let pfix = getCompletionPrefixFromRope position cnts
             case (pfix, completionContext) of
               (PosPrefixInfo _ "" _ _, Just CompletionContext { _triggerCharacter = Just "."})
                 -> return (InL [])

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

@@ -15,6 +15,8 @@ import qualified Data.List                       as List
 import qualified Data.Maybe                      as Maybe
 import           Data.Text                       (Text, pack)
 import qualified Data.Text                       as Text
+import           Data.Text.Utf16.Rope.Mixed      (Rope)
+import qualified Data.Text.Utf16.Rope.Mixed      as Rope
 import           Development.IDE                 (srcSpanToRange, IdeState, NormalizedFilePath, GhcSession (..), getFileContents, hscEnv, runAction)
 import           Development.IDE.GHC.Compat
 import           Development.IDE.GHC.Compat.Util
@@ -27,10 +29,10 @@ import qualified Data.Text                      as T
 import           Development.IDE.Core.PluginUtils
 import qualified Language.LSP.Protocol.Lens     as L
 
-getNextPragmaInfo :: DynFlags -> Maybe Text -> NextPragmaInfo
-getNextPragmaInfo dynFlags mbSourceText =
-  if | Just sourceText <- mbSourceText
-     , let sourceStringBuffer = stringToStringBuffer (Text.unpack sourceText)
+getNextPragmaInfo :: DynFlags -> Maybe Rope -> NextPragmaInfo
+getNextPragmaInfo dynFlags mbSource =
+  if | Just source <- mbSource
+     , let sourceStringBuffer = stringToStringBuffer (Text.unpack (Rope.toText source))
      , POk _ parserState <- parsePreDecl dynFlags sourceStringBuffer
      -> case parserState of
          ParserStateNotDone{ nextPragma } -> nextPragma
@@ -56,7 +58,7 @@ insertNewPragma (NextPragmaInfo nextPragmaLine _) newPragma =  LSP.TextEdit prag
 getFirstPragma :: MonadIO m => PluginId -> IdeState -> NormalizedFilePath -> ExceptT PluginError m NextPragmaInfo
 getFirstPragma (PluginId pId) state nfp = do
   (hscEnv -> hsc_dflags -> sessionDynFlags, _) <- runActionE (T.unpack pId <> ".GhcSession") state $ useWithStaleE GhcSession nfp
-  (_, fileContents) <- liftIO $ runAction (T.unpack pId <> ".GetFileContents") state $ getFileContents nfp
+  fileContents <- liftIO $ runAction (T.unpack pId <> ".GetFileContents") state $ getFileContents nfp
   pure $ getNextPragmaInfo sessionDynFlags fileContents
 
 -- Pre-declaration comments parser -----------------------------------------------------

haskell-language-server.cabal

@@ -265,6 +265,7 @@ library hls-cabal-plugin
     , lsp-types             ^>=2.3
     , regex-tdfa            ^>=1.3.1
     , text
+    , text-rope
     , transformers
     , unordered-containers  >=0.2.10.0
     , containers
@@ -470,6 +471,7 @@ library hls-eval-plugin
     , mtl
     , parser-combinators    >=1.2
     , text
+    , text-rope
     , transformers
     , unliftio
     , unordered-containers
@@ -650,6 +652,7 @@ library hls-retrie-plugin
     , safe-exceptions
     , stm
     , text
+    , text-rope
     , transformers
     , unordered-containers
 
@@ -719,6 +722,7 @@ library hls-hlint-plugin
     , stm
     , temporary
     , text
+    , text-rope
     , transformers
     , unordered-containers
     , ghc-lib-parser-ex
@@ -847,6 +851,7 @@ library hls-module-name-plugin
     , hls-plugin-api        == 2.9.0.0
     , lsp
     , text
+    , text-rope
     , transformers
 
 
@@ -1061,6 +1066,7 @@ library hls-qualify-imported-names-plugin
     , lens
     , lsp
     , text
+    , text-rope
     , dlist
     , transformers
 
@@ -1655,6 +1661,7 @@ library hls-refactor-plugin
     , hls-plugin-api        == 2.9.0.0
     , lsp
     , text
+    , text-rope
     , transformers
     , unordered-containers
     , containers