haskell · mergify · Aug 12, 2022 · Aug 1, 2022 · Aug 1, 2022 · Aug 2, 2022
diff --git a/cabal.project b/cabal.project
@@ -44,7 +44,7 @@ package *
 
 write-ghc-environment-files: never
 
-index-state: 2022-06-12T00:00:00Z
+index-state: 2022-07-31T21:47:51Z
 
 constraints:
   hyphenation +embed,

@@ -301,7 +301,7 @@ launchErrorLSP errorMsg = do
         let interpretHandler (env,  _st) = LSP.Iso (LSP.runLspT env . unErrorLSPM) liftIO
         pure (doInitialize, asyncHandlers, interpretHandler)
 
-  runLanguageServer
+  runLanguageServer (cmapWithPrio pretty recorder)
     (Main.argsLspOptions defaultArguments)
     inH
     outH

diff --git a/flake.lock b/flake.lock
@@ -21,15 +21,15 @@
 
     # List of hackage dependencies
     lsp = {
-      url = "https://hackage.haskell.org/package/lsp-1.4.0.0/lsp-1.4.0.0.tar.gz";
+      url = "https://hackage.haskell.org/package/lsp-1.5.0.0/lsp-1.5.0.0.tar.gz";
       flake = false;
     };
     lsp-types = {
-      url = "https://hackage.haskell.org/package/lsp-types-1.4.0.1/lsp-types-1.4.0.1.tar.gz";
+      url = "https://hackage.haskell.org/package/lsp-types-1.5.0.0/lsp-types-1.5.0.0.tar.gz";
       flake = false;
     };
     lsp-test = {
-      url = "https://hackage.haskell.org/package/lsp-test-0.14.0.2/lsp-test-0.14.0.2.tar.gz";
+      url = "https://hackage.haskell.org/package/lsp-test-0.14.0.3/lsp-test-0.14.0.3.tar.gz";
       flake = false;
     };
     ghc-exactprint-150 = {

@@ -46,6 +46,7 @@ library
         binary,
         bytestring,
         case-insensitive,
+        co-log-core,
         containers,
         data-default,
         deepseq,
@@ -69,8 +70,8 @@ library
         lens,
         list-t,
         hiedb == 0.4.1.*,
-        lsp-types ^>= 1.4.0.1,
-        lsp ^>= 1.4.0.0 ,
+        lsp-types ^>= 1.5.0.0,
+        lsp ^>= 1.5.0.0 ,
         monoid-subclasses,
         mtl,
         network-uri,
@@ -81,7 +82,7 @@ library
         random,
         regex-tdfa >= 1.3.1.0,
         retrie,
-        rope-utf16-splay,
+        text-rope,
         safe,
         safe-exceptions,
         hls-graph ^>= 1.7,
@@ -421,7 +422,6 @@ test-suite ghcide-tests
         QuickCheck,
         quickcheck-instances,
         random,
-        rope-utf16-splay,
         regex-tdfa ^>= 1.3.1,
         safe,
         safe-exceptions,
@@ -436,6 +436,7 @@ test-suite ghcide-tests
         tasty-quickcheck,
         tasty-rerun,
         text,
+        text-rope,
         unordered-containers,
         vector,
     if (impl(ghc >= 8.6) && impl(ghc < 9.2))

@@ -28,8 +28,8 @@ import           Control.Exception
 import           Control.Monad.Extra
 import           Control.Monad.IO.Class
 import qualified Data.ByteString                              as BS
-import qualified Data.Rope.UTF16                              as Rope
 import qualified Data.Text                                    as T
+import qualified Data.Text.Utf16.Rope                         as Rope
 import           Data.Time
 import           Data.Time.Clock.POSIX
 import           Development.IDE.Core.FileUtils
@@ -188,7 +188,7 @@ getFileContentsImpl file = do
     time <- use_ GetModificationTime file
     res <- do
         mbVirtual <- getVirtualFile file
-        pure $ Rope.toText . _text <$> mbVirtual
+        pure $ Rope.toText . _file_text <$> mbVirtual
     pure ([], Just (time, res))
 
 -- | Returns the modification time and the contents.

@@ -92,7 +92,7 @@ import qualified Data.IntMap.Strict                           as IntMap
 import           Data.List
 import qualified Data.Map                                     as M
 import           Data.Maybe
-import qualified Data.Rope.UTF16                              as Rope
+import qualified Data.Text.Utf16.Rope                         as Rope
 import qualified Data.Set                                     as Set
 import qualified Data.Text                                    as T
 import qualified Data.Text.Encoding                           as T
@@ -574,10 +574,10 @@ persistentHieFileRule :: Recorder (WithPriority Log) -> Rules ()
 persistentHieFileRule recorder = addPersistentRule GetHieAst $ \file -> runMaybeT $ do
   res <- readHieFileForSrcFromDisk recorder file
   vfsRef <- asks vfsVar
-  vfsData <- liftIO $ vfsMap <$> readTVarIO vfsRef
+  vfsData <- liftIO $ _vfsMap <$> readTVarIO vfsRef
   (currentSource, ver) <- liftIO $ case M.lookup (filePathToUri' file) vfsData of
     Nothing -> (,Nothing) . T.decodeUtf8 <$> BS.readFile (fromNormalizedFilePath file)
-    Just vf -> pure (Rope.toText $ _text vf, Just $ _lsp_version vf)
+    Just vf -> pure (Rope.toText $ _file_text vf, Just $ _lsp_version vf)
   let refmap = Compat.generateReferencesMap . Compat.getAsts . Compat.hie_asts $ res
       del = deltaFromDiff (T.decodeUtf8 $ Compat.hie_hs_src res) currentSource
   pure (HAR (Compat.hie_module res) (Compat.hie_asts res) refmap mempty (HieFromDisk res),del,ver)
@@ -1108,8 +1108,8 @@ getLinkableType f = use_ NeedsCompilation f
 
 -- needsCompilationRule :: Rules ()
 needsCompilationRule :: NormalizedFilePath  -> Action (IdeResultNoDiagnosticsEarlyCutoff (Maybe LinkableType))
-needsCompilationRule file 
-  | "boot" `isSuffixOf` (fromNormalizedFilePath file) = 
+needsCompilationRule file
+  | "boot" `isSuffixOf` (fromNormalizedFilePath file) =
     pure (Just $ encodeLinkableType Nothing, Just Nothing)
 needsCompilationRule file = do
   graph <- useNoFile GetModuleGraph

@@ -164,7 +164,7 @@ import qualified Language.LSP.Server                    as LSP
 import           Language.LSP.Types
 import qualified Language.LSP.Types                     as LSP
 import           Language.LSP.Types.Capabilities
-import           Language.LSP.VFS
+import           Language.LSP.VFS                       hiding (start)
 import qualified "list-t" ListT
 import           OpenTelemetry.Eventlog
 import qualified StmContainers.Map                      as STM
@@ -323,7 +323,7 @@ class Typeable a => IsIdeGlobal a where
 -- | Read a virtual file from the current snapshot
 getVirtualFile :: NormalizedFilePath -> Action (Maybe VirtualFile)
 getVirtualFile nf = do
-  vfs <- fmap vfsMap . liftIO . readTVarIO . vfsVar =<< getShakeExtras
+  vfs <- fmap _vfsMap . liftIO . readTVarIO . vfsVar =<< getShakeExtras
   pure $! Map.lookup (filePathToUri' nf) vfs -- Don't leak a reference to the entire map
 
 -- Take a snapshot of the current LSP VFS
@@ -706,6 +706,7 @@ shakeRestart recorder IdeState{..} vfs reason acts =
               backlog <- readTVarIO $ dirtyKeys shakeExtras
               queue <- atomicallyNamed "actionQueue - peek" $ peekInProgress $ actionQueue shakeExtras
 
+              -- this log is required by tests
               log Debug $ LogBuildSessionRestart reason queue backlog stopTime res
         )
         -- It is crucial to be masked here, otherwise we can get killed

@@ -34,17 +34,17 @@ import           UnliftIO.Concurrent
 import           UnliftIO.Directory
 import           UnliftIO.Exception
 
+import qualified Colog.Core                            as Colog
+import           Control.Monad.IO.Unlift               (MonadUnliftIO)
 import           Development.IDE.Core.IdeConfiguration
-import           Development.IDE.Core.Shake            hiding (Log)
+import           Development.IDE.Core.Shake            hiding (Log, Priority)
 import           Development.IDE.Core.Tracing
-import           Development.IDE.Types.Logger
-
-import           Control.Monad.IO.Unlift               (MonadUnliftIO)
-import           Data.Kind                             (Type)
 import qualified Development.IDE.Session               as Session
+import           Development.IDE.Types.Logger
 import qualified Development.IDE.Types.Logger          as Logger
 import           Development.IDE.Types.Shake           (WithHieDb)
 import           Language.LSP.Server                   (LanguageContextEnv,
+                                                        LspServerLog,
                                                         type (<~>))
 import           System.IO.Unsafe                      (unsafeInterleaveIO)
 
@@ -55,6 +55,7 @@ data Log
   | LogReactorThreadStopped
   | LogCancelledRequest !SomeLspId
   | LogSession Session.Log
+  | LogLspServer LspServerLog
   deriving Show
 
 instance Pretty Log where
@@ -74,13 +75,15 @@ instance Pretty Log where
     LogCancelledRequest requestId ->
       "Cancelled request" <+> viaShow requestId
     LogSession log -> pretty log
+    LogLspServer log -> pretty log
 
 -- used to smuggle RankNType WithHieDb through dbMVar
 newtype WithHieDbShield = WithHieDbShield WithHieDb
 
 runLanguageServer
     :: forall config a m. (Show config)
-    => LSP.Options
+    => Recorder (WithPriority Log)
+    -> LSP.Options
     -> Handle -- input
     -> Handle -- output
     -> config
@@ -90,7 +93,7 @@ runLanguageServer
                LSP.Handlers (m config),
                (LanguageContextEnv config, a) -> m config <~> IO))
     -> IO ()
-runLanguageServer options inH outH defaultConfig onConfigurationChange setup = do
+runLanguageServer recorder options inH outH defaultConfig onConfigurationChange setup = do
     -- This MVar becomes full when the server thread exits or we receive exit message from client.
     -- LSP server will be canceled when it's full.
     clientMsgVar <- newEmptyMVar
@@ -106,8 +109,15 @@ runLanguageServer options inH outH defaultConfig onConfigurationChange setup = d
             , LSP.options = modifyOptions options
             }
 
+    let lspCologAction :: MonadIO m2 => Colog.LogAction m2 (Colog.WithSeverity LspServerLog)
+        lspCologAction = toCologActionWithPrio $ cfilter
+            (\msg -> priority msg >= Info)
+            (cmapWithPrio LogLspServer recorder)
+
     void $ untilMVar clientMsgVar $
           void $ LSP.runServerWithHandles
+            lspCologAction
+            lspCologAction
             inH
             outH
             serverDefinition

@@ -385,7 +385,7 @@ defaultMain recorder Arguments{..} = withHeapStats (cmapWithPrio LogHeapStats re
 
             let setup = setupLSP (cmapWithPrio LogLanguageServer recorder) argsGetHieDbLoc (pluginHandlers plugins) getIdeState
 
-            runLanguageServer options inH outH argsDefaultHlsConfig argsOnConfigChange setup
+            runLanguageServer (cmapWithPrio LogLanguageServer recorder) options inH outH argsDefaultHlsConfig argsOnConfigChange setup
             dumpSTMStats
         Check argFiles -> do
           dir <- maybe IO.getCurrentDirectory return argsProjectRoot

@@ -36,9 +36,9 @@ import qualified Data.List.NonEmpty                                as NE
 import qualified Data.Map.Strict                                   as M
 import           Data.Maybe
 import           Data.Ord                                          (comparing)
-import qualified Data.Rope.UTF16                                   as Rope
 import qualified Data.Set                                          as S
 import qualified Data.Text                                         as T
+import qualified Data.Text.Utf16.Rope                              as Rope
 import           Data.Tuple.Extra                                  (fst3)
 import           Development.IDE.Core.Rules
 import           Development.IDE.Core.RuleTypes
@@ -75,7 +75,8 @@ import           Language.LSP.Types                                (CodeAction (
                                                                     WorkspaceEdit (WorkspaceEdit, _changeAnnotations, _changes, _documentChanges),
                                                                     type (|?) (InR),
                                                                     uriToFilePath)
-import           Language.LSP.VFS
+import           Language.LSP.VFS                                  (VirtualFile,
+                                                                    _file_text)
 import           Text.Regex.TDFA                                   (mrAfter,
                                                                     (=~), (=~~))
 #if MIN_VERSION_ghc(9,2,0)
@@ -109,7 +110,7 @@ codeAction
 codeAction state _ (CodeActionParams _ _ (TextDocumentIdentifier uri) _range CodeActionContext{_diagnostics=List xs}) = do
   contents <- LSP.getVirtualFile $ toNormalizedUri uri
   liftIO $ do
-    let text = Rope.toText . (_text :: VirtualFile -> Rope.Rope) <$> contents
+    let text = Rope.toText . (_file_text :: VirtualFile -> Rope.Rope) <$> contents
         mbFile = toNormalizedFilePath' <$> uriToFilePath uri
     diag <- atomically $ fmap (\(_, _, d) -> d) . filter (\(p, _, _) -> mbFile == Just p) <$> getDiagnostics state
     (join -> parsedModule) <- runAction "GhcideCodeActions.getParsedModule" state $ getParsedModule `traverse` mbFile

@@ -27,7 +27,6 @@ import           Data.Text                            (Text, pack)
 import           Development.IDE.Core.OfInterest      (getFilesOfInterest)
 import           Development.IDE.Core.Rules
 import           Development.IDE.Core.RuleTypes
-import           Development.IDE.Core.Service
 import           Development.IDE.Core.Shake
 import           Development.IDE.GHC.Compat
 import           Development.IDE.Graph                (Action)

@@ -27,6 +27,7 @@ module Development.IDE.Types.Logger
   , lspClientLogRecorder
   , module PrettyPrinterModule
   , renderStrict
+  , toCologActionWithPrio
   ) where
 
 import           Control.Concurrent                    (myThreadId)
@@ -59,7 +60,6 @@ import           Language.LSP.Server
 import qualified Language.LSP.Server                   as LSP
 import           Language.LSP.Types                    (LogMessageParams (..),
                                                         MessageType (..),
-                                                        ResponseError,
                                                         SMethod (SWindowLogMessage, SWindowShowMessage),
                                                         ShowMessageParams (..))
 #if MIN_VERSION_prettyprinter(1,7,0)
@@ -69,11 +69,10 @@ import           Prettyprinter.Render.Text             (renderStrict)
 import           Data.Text.Prettyprint.Doc             as PrettyPrinterModule
 import           Data.Text.Prettyprint.Doc.Render.Text (renderStrict)
 #endif
-import           Control.Lens                          ((^.))
-import           Ide.Types                             (CommandId (CommandId),
-                                                        PluginId (PluginId))
-import           Language.LSP.Types.Lens               (HasCode (code),
-                                                        HasMessage (message))
+import           Colog.Core                            (LogAction (..),
+                                                        Severity,
+                                                        WithSeverity (..))
+import qualified Colog.Core                            as Colog
 import           System.IO                             (Handle,
                                                         IOMode (AppendMode),
                                                         hClose, hFlush,
@@ -381,3 +380,14 @@ priorityToLsp =
     Info    -> MtInfo
     Warning -> MtWarning
     Error   -> MtError
+
+toCologActionWithPrio :: (MonadIO m, HasCallStack) => Recorder (WithPriority msg) -> LogAction m (WithSeverity msg)
+toCologActionWithPrio (Recorder _logger) = LogAction $ \WithSeverity{..} -> do
+    let priority = severityToPriority getSeverity
+    _logger $ WithPriority priority callStack getMsg
+  where
+    severityToPriority :: Severity -> Priority
+    severityToPriority Colog.Debug   = Debug
+    severityToPriority Colog.Info    = Info
+    severityToPriority Colog.Warning = Warning
+    severityToPriority Colog.Error   = Error