Move formatting over to VFS away from IdeGhcM

Makes it a lot faster

hie-plugin-api/Haskell/Ide/Engine/PluginUtils.hs

@@ -29,6 +29,9 @@ module Haskell.Ide.Engine.PluginUtils
   , unPos
   , toPos
   , clientSupportsDocumentChanges
+  , readVFS
+  , getRangeFromVFS
+  , rangeLinesFromVfs
   ) where
 
 import           Control.Monad.IO.Class
@@ -47,12 +50,14 @@ import           FastString
 import           Haskell.Ide.Engine.MonadTypes
 import           Haskell.Ide.Engine.MonadFunctions
 import           Haskell.Ide.Engine.ArtifactMap
+import           Language.Haskell.LSP.VFS
 import           Language.Haskell.LSP.Types.Capabilities
 import qualified Language.Haskell.LSP.Types            as J
 import           Prelude                               hiding (log)
 import           SrcLoc
 import           System.Directory
 import           System.FilePath
+import qualified Yi.Rope as Yi
 
 -- ---------------------------------------------------------------------
 
@@ -261,3 +266,26 @@ clientSupportsDocumentChanges = do
         WorkspaceEditClientCapabilities mDc <- _workspaceEdit wCaps
         mDc
   return $ fromMaybe False supports
+
+-- ---------------------------------------------------------------------
+
+readVFS :: MonadIde m => Uri -> m (Maybe T.Text)
+readVFS uri = do
+  mvf <- getVirtualFile uri
+  case mvf of
+    Just (VirtualFile _ txt) -> return $ Just (Yi.toText txt)
+    Nothing -> return Nothing
+
+getRangeFromVFS :: MonadIde m => Uri -> Range -> m (Maybe T.Text)
+getRangeFromVFS uri rg = do
+  mvf <- getVirtualFile uri
+  case mvf of
+    Just vfs -> return $ Just $ rangeLinesFromVfs vfs rg
+    Nothing  -> return Nothing
+
+rangeLinesFromVfs :: VirtualFile -> Range -> T.Text
+rangeLinesFromVfs (VirtualFile _ yitext) (Range (Position lf _cf) (Position lt _ct)) = r
+  where
+    (_ ,s1) = Yi.splitAtLine lf yitext
+    (s2, _) = Yi.splitAtLine (lt - lf) s1
+    r = Yi.toText s2

hie-plugin-api/Haskell/Ide/Engine/PluginsIdeMonads.hs

@@ -210,7 +210,7 @@ type SymbolProvider = Uri -> IdeDeferM (IdeResult [DocumentSymbol])
 
 data FormattingType = FormatDocument
                     | FormatRange Range
-type FormattingProvider = Uri -> FormattingType -> FormattingOptions -> IdeGhcM (IdeResult [TextEdit])
+type FormattingProvider = Uri -> FormattingType -> FormattingOptions -> IdeDeferM (IdeResult [TextEdit])
 
 data PluginDescriptor =
   PluginDescriptor { pluginId                 :: PluginId

hie-plugin-api/hie-plugin-api.cabal

@@ -50,6 +50,7 @@ library
                      , text
                      , transformers
                      , unordered-containers
+                     , yi-rope
   if os(windows)
     build-depends:     Win32
   else

src/Haskell/Ide/Engine/Plugin/Brittany.hs

@@ -5,15 +5,16 @@ module Haskell.Ide.Engine.Plugin.Brittany where
 
 import           Control.Lens
 import           Control.Monad.IO.Class
+import           Control.Monad.Trans.Class
 import           Control.Monad.Trans.Maybe (MaybeT, runMaybeT)
 import           Data.Aeson
 import           Data.Coerce
 import           Data.Semigroup
 import           Data.Text                             (Text)
 import qualified Data.Text                             as T
-import qualified Data.Text.IO                          as T
+-- import qualified Data.Text.IO                          as T
 import           GHC.Generics
-import qualified GhcMod.Utils                          as GM
+-- import qualified GhcMod.Utils                          as GM
 import           Haskell.Ide.Engine.MonadTypes
 import           Haskell.Ide.Engine.PluginUtils
 import           Language.Haskell.Brittany
@@ -43,17 +44,18 @@ brittanyDescriptor plId = PluginDescriptor
  where
   cmd :: CommandFunc FormatParams [J.TextEdit]
   cmd =
-    CmdSync $ \(FormatParams tabSize uri range) -> brittanyCmd tabSize uri range
+    CmdSync $ \(FormatParams tabSize uri range) -> liftToGhc $ brittanyCmd tabSize uri range
   provider :: FormattingProvider
-  provider uri FormatDocument opts = brittanyCmd (opts ^. J.tabSize) uri Nothing
-  provider uri (FormatRange r) opts = brittanyCmd (opts ^. J.tabSize) uri (Just r)
+  provider uri FormatDocument opts = lift $ brittanyCmd (opts ^. J.tabSize) uri Nothing
+  provider uri (FormatRange r) opts = lift $ brittanyCmd (opts ^. J.tabSize) uri (Just r)
 
-brittanyCmd :: Int -> Uri -> Maybe Range -> IdeGhcM (IdeResult [J.TextEdit])
-brittanyCmd tabSize uri range =
-  pluginGetFile "brittanyCmd: " uri $ \file -> do
-    confFile <- liftIO $ getConfFile file
-    text <- GM.withMappedFile file $ liftIO . T.readFile
-    case range of
+brittanyCmd :: Int -> Uri -> Maybe Range -> IdeM (IdeResult [J.TextEdit])
+brittanyCmd tabSize uri range = pluginGetFile "brittanyCmd: " uri $ \file -> do
+  confFile <- liftIO $ getConfFile file
+  mtext <- readVFS uri
+  case mtext of
+    Nothing -> return $ IdeResultFail (IdeError InternalError "File was not open" Null)
+    Just text -> case range of
       Just r -> do
         -- format selection
         res <- liftIO $ runBrittany tabSize confFile $ extractRange r text

src/Haskell/Ide/Engine/Plugin/Floskell.hs

@@ -8,13 +8,10 @@ where
 import           Data.Aeson                     ( Value(Null) )
 import qualified Data.ByteString.Lazy          as BS
 import qualified Data.Text                     as T
-import qualified Data.Text.IO                  as T
 import qualified Data.Text.Encoding            as T
-import qualified GhcMod.Utils                  as GM
 import           Haskell.Ide.Engine.MonadTypes
 import           Haskell.Ide.Engine.PluginUtils
 import           FloskellFloskell
-import           Control.Monad.IO.Class
 
 floskellDescriptor :: PluginId -> PluginDescriptor
 floskellDescriptor plId = PluginDescriptor
@@ -30,12 +27,15 @@ floskellDescriptor plId = PluginDescriptor
   }
 
 provider :: FormattingProvider
-provider uri typ _opts = pluginGetFile "floskell: " uri $ \file -> do
-  contents <- GM.withMappedFile file (liftIO . T.readFile)
-  let (range, selectedContents) = case typ of
-        FormatDocument -> (fullRange contents, contents)
-        FormatRange r  -> (r, extractRange r contents)
-      result = reformat defaultAppConfig (uriToFilePath uri) (T.encodeUtf8 selectedContents)
-  case result of
-    Left  err -> return $ IdeResultFail (IdeError PluginError (T.pack err) Null)
-    Right new -> return $ IdeResultOk [TextEdit range (T.decodeUtf8 (BS.toStrict new))]
+provider uri typ _opts = do
+  mContents <- readVFS uri
+  case mContents of
+    Nothing -> return $ IdeResultFail (IdeError InternalError "File was not open" Null)
+    Just contents ->
+      let (range, selectedContents) = case typ of
+            FormatDocument -> (fullRange contents, contents)
+            FormatRange r  -> (r, extractRange r contents)
+          result = reformat defaultAppConfig (uriToFilePath uri) (T.encodeUtf8 selectedContents)
+      in case result of
+        Left  err -> return $ IdeResultFail (IdeError PluginError (T.pack err) Null)
+        Right new -> return $ IdeResultOk [TextEdit range (T.decodeUtf8 (BS.toStrict new))]

src/Haskell/Ide/Engine/Plugin/HfaAlign.hs

@@ -12,7 +12,7 @@ import           Data.Aeson
 import qualified Data.HashMap.Strict           as H
 import qualified GHC.Generics                  as Generics
 import           Haskell.Ide.Engine.MonadTypes hiding (_range)
-import           Haskell.Ide.Engine.Plugin.HieExtras
+import           Haskell.Ide.Engine.PluginUtils
 import qualified Language.Haskell.LSP.Types      as J
 import qualified Language.Haskell.LSP.Types.Lens as J
 
@@ -50,7 +50,7 @@ data AlignParams = AlignParams
 
 alignCmd :: CommandFunc AlignParams J.WorkspaceEdit
 alignCmd = CmdSync $ \(AlignParams uri rg) -> do
-  mtext <- liftToGhc $ getRangeFromVFS uri rg
+  mtext <- getRangeFromVFS uri rg
   case mtext of
     Nothing -> return $ IdeResultOk $ J.WorkspaceEdit Nothing Nothing
     Just txt -> do

src/Haskell/Ide/Engine/Plugin/HieExtras.hs

@@ -15,8 +15,6 @@ module Haskell.Ide.Engine.Plugin.HieExtras
   , showName
   , safeTyThingId
   , PosPrefixInfo(..)
-  , getRangeFromVFS
-  , rangeLinesFromVfs
   , HarePoint(..)
   , customOptions
   , runGhcModCommand
@@ -59,7 +57,6 @@ import           Haskell.Ide.Engine.MonadTypes
 import           Haskell.Ide.Engine.PluginUtils
 import qualified Haskell.Ide.Engine.Plugin.Fuzzy              as Fuzzy
 import           HscTypes
-import qualified Language.Haskell.LSP.VFS                     as VFS
 import qualified Language.Haskell.LSP.Types                   as J
 import qualified Language.Haskell.LSP.Types.Lens              as J
 import           Language.Haskell.Refact.API                 (showGhc)
@@ -73,7 +70,6 @@ import           SrcLoc
 import           TcEnv
 import           Type
 import           Var
-import qualified Yi.Rope as Yi
 
 -- ---------------------------------------------------------------------
 
@@ -600,22 +596,6 @@ findDef uri pos = pluginGetFile "findDef: " uri $ \file ->
 
 -- ---------------------------------------------------------------------
 
-getRangeFromVFS :: Uri -> Range -> IdeM (Maybe T.Text)
-getRangeFromVFS uri rg = do
-  mvf <- getVirtualFile uri
-  case mvf of
-    Just vfs -> return $ Just $ rangeLinesFromVfs vfs rg
-    Nothing  -> return Nothing
-
-rangeLinesFromVfs :: VFS.VirtualFile -> Range -> T.Text
-rangeLinesFromVfs (VFS.VirtualFile _ yitext) (Range (Position lf _cf) (Position lt _ct)) = r
-  where
-    (_ ,s1) = Yi.splitAtLine lf yitext
-    (s2, _) = Yi.splitAtLine (lt - lf) s1
-    r = Yi.toText s2
-
--- ---------------------------------------------------------------------
-
 data HarePoint =
   HP { hpFile :: Uri
      , hpPos  :: Position

src/Haskell/Ide/Engine/Transport/LspStdio.hs

@@ -52,7 +52,6 @@ import           Haskell.Ide.Engine.LSP.Reactor
 import qualified Haskell.Ide.Engine.Plugin.HaRe          as HaRe
 import qualified Haskell.Ide.Engine.Plugin.GhcMod        as GhcMod
 import qualified Haskell.Ide.Engine.Plugin.ApplyRefact   as ApplyRefact
-import qualified Haskell.Ide.Engine.Plugin.Brittany      as Brittany
 import qualified Haskell.Ide.Engine.Plugin.Hoogle        as Hoogle
 import qualified Haskell.Ide.Engine.Plugin.HieExtras     as Hie
 import           Haskell.Ide.Engine.Plugin.Base
@@ -721,39 +720,23 @@ reactor inp diagIn = do
 
         ReqDocumentFormatting req -> do
           liftIO $ U.logs $ "reactor:got FormatRequest:" ++ show req
-          providers <- asks formattingProviders
-          lf <- asks lspFuncs
-          mc <- liftIO $ Core.config lf
-          let providerName = formattingProvider (fromMaybe def mc)
-              providerType = Map.lookup providerName providers
-          case providerType of
-            Nothing -> do
-              reactorSend (RspDocumentFormatting (Core.makeResponseMessage req (J.List [])))
-              unless (providerName == "none") $ do
-                let msg = providerName <> " is not a recognised plugin for formatting. Check your config"
-                reactorSend $ NotShowMessage $ fmServerShowMessageNotification J.MtWarning msg
-                reactorSend $ NotLogMessage $ fmServerLogMessageNotification J.MtWarning msg    
-            Just provider ->
-              -- LL: Is this overengineered? Do we need a pluginFormattingProvider
-              -- or should we just call plugins straight from here based on the providerType?
-              let params = req ^. J.params
-                  doc = params ^. J.textDocument . J.uri
-                  callback = reactorSend . RspDocumentFormatting . Core.makeResponseMessage req . J.List
-                  hreq = GReq tn (Just doc) Nothing (Just $ req ^. J.id) callback
-                          $ provider doc FormatDocument (params ^. J.options)
-              in makeRequest hreq
+          provider <- getFormattingProvider
+          let params = req ^. J.params
+              doc = params ^. J.textDocument . J.uri
+              callback = reactorSend . RspDocumentFormatting . Core.makeResponseMessage req . J.List
+              hreq = IReq tn (req ^. J.id) callback $ provider doc FormatDocument (params ^. J.options)
+          makeRequest hreq
 
         -- -------------------------------
 
         ReqDocumentRangeFormatting req -> do
           liftIO $ U.logs $ "reactor:got FormatRequest:" ++ show req
+          provider <- getFormattingProvider
           let params = req ^. J.params
               doc = params ^. J.textDocument . J.uri
               range = params ^. J.range
-              tabSize = params ^. J.options . J.tabSize
               callback = reactorSend . RspDocumentRangeFormatting . Core.makeResponseMessage req . J.List
-          let hreq = GReq tn (Just doc) Nothing (Just $ req ^. J.id) callback
-                       $ Brittany.brittanyCmd tabSize doc (Just range)
+              hreq = IReq tn (req ^. J.id) callback $ provider doc (FormatRange range) (params ^. J.options)
           makeRequest hreq
 
         -- -------------------------------
@@ -812,6 +795,26 @@ reactor inp diagIn = do
 
 -- ---------------------------------------------------------------------
 
+getFormattingProvider :: R FormattingProvider
+getFormattingProvider = do
+  providers <- asks formattingProviders
+  lf <- asks lspFuncs
+  mc <- liftIO $ Core.config lf
+  -- LL: Is this overengineered? Do we need a pluginFormattingProvider
+  -- or should we just call plugins straight from here based on the providerType?
+  let providerName = formattingProvider (fromMaybe def mc)
+      mProvider = Map.lookup providerName providers
+  case mProvider of
+    Nothing -> do
+      unless (providerName == "none") $ do
+        let msg = providerName <> " is not a recognised plugin for formatting. Check your config"
+        reactorSend $ NotShowMessage $ fmServerShowMessageNotification J.MtWarning msg
+        reactorSend $ NotLogMessage $ fmServerLogMessageNotification J.MtWarning msg    
+      return (\_ _ _ -> return (IdeResultOk [])) -- nop formatter
+    Just provider -> return provider
+
+-- ---------------------------------------------------------------------
+
 -- | Queue a diagnostics request to be performed after a timeout. This prevents recompiling
 -- too often when there is a quick stream of changes.
 queueDiagnosticsRequest