Adjust rendering of error logs and drop unneeded MonadUnliftIO instan…

…ce (#2755) * drop unneeded MonadUnliftIO instance * Adjust error message * fixups
haskell · Mar 6, 2022 · 30b3fec · 30b3fec
1 parent b7f37ad
commit 30b3fec
Show file tree

Hide file tree

Showing 5 changed files with 13 additions and 16 deletions.
diff --git a/exe/Main.hs b/exe/Main.hs
@@ -5,6 +5,8 @@
 module Main(main) where
 
 import           Data.Function                ((&))
+import           Data.Text (Text)
+import           Development.IDE.Plugin.LSPWindowShowMessageRecorder (makeLspShowMessageRecorder)
 import           Development.IDE.Types.Logger (Priority (Debug, Info, Error),
                                                WithPriority (WithPriority, priority),
                                                cfilter, cmapWithPrio,
@@ -15,11 +17,9 @@ import           Ide.Arguments                (Arguments (..),
                                                getArguments)
 import           Ide.Main                     (defaultMain)
 import qualified Ide.Main                     as IdeMain
+import           Ide.PluginUtils (pluginDescToIdePlugins)
 import qualified Plugins
-import           Prettyprinter                (Pretty (pretty), vcat)
-import Development.IDE.Plugin.LSPWindowShowMessageRecorder (makeLspShowMessageRecorder)
-import Data.Text (Text)
-import Ide.PluginUtils (pluginDescToIdePlugins)
+import           Prettyprinter                (Pretty (pretty), vsep)
 
 data Log
   = LogIdeMain IdeMain.Log
@@ -59,8 +59,8 @@ main = do
       defaultMain (cmapWithPrio LogIdeMain recorder) args (pluginDescToIdePlugins [lspRecorderPlugin] <> plugins)
 
 renderDoc :: Doc a -> Text
-renderDoc d = renderStrict $ layoutPretty defaultLayoutOptions $ vcat
-    ["Unhandled exception, please check your setup and/or the [issue tracker](" <> issueTrackerUrl <> "): "
+renderDoc d = renderStrict $ layoutPretty defaultLayoutOptions $ vsep
+    ["Error condition, please check your setup and/or the [issue tracker](" <> issueTrackerUrl <> "): "
     ,d
     ]
 

diff --git a/ghcide/src/Development/IDE/Plugin/LSPWindowShowMessageRecorder.hs b/ghcide/src/Development/IDE/Plugin/LSPWindowShowMessageRecorder.hs
@@ -3,7 +3,6 @@
 module Development.IDE.Plugin.LSPWindowShowMessageRecorder (makeLspShowMessageRecorder) where
 
 import Control.Monad.IO.Class
-import Control.Monad.IO.Unlift (MonadUnliftIO)
 import Data.Foldable (for_)
 import Data.IORef
 import Data.IORef.Extra (atomicModifyIORef'_)
@@ -24,8 +23,8 @@ makeLspShowMessageRecorder = do
   backLogRef <- newIORef []
   let recorder = Recorder $ \it -> do
         mbenv <- liftIO $ readIORef envRef
-        case mbenv of
-          Nothing -> liftIO $ atomicModifyIORef'_ backLogRef (it :)
+        liftIO $ case mbenv of
+          Nothing -> atomicModifyIORef'_ backLogRef (it :)
           Just env -> sendMsg env it
       -- the plugin captures the language context, so it can be used to send messages
       plugin =
@@ -35,11 +34,11 @@ makeLspShowMessageRecorder = do
               liftIO $ writeIORef envRef $ Just env
               -- flush the backlog
               backLog <- liftIO $ atomicModifyIORef' backLogRef ([],)
-              for_ (reverse backLog) $ sendMsg env
+              liftIO $ for_ (reverse backLog) $ sendMsg env
           }
   return (recorder, plugin)
 
-sendMsg :: MonadUnliftIO m => LanguageContextEnv config -> WithPriority Text -> m ()
+sendMsg :: LanguageContextEnv config -> WithPriority Text -> IO ()
 sendMsg env WithPriority {..} =
   LSP.runLspT env $
     LSP.sendNotification

diff --git a/ghcide/src/Development/IDE/Types/Logger.hs b/ghcide/src/Development/IDE/Types/Logger.hs
@@ -97,9 +97,9 @@ data WithPriority a = WithPriority { priority :: Priority, callStack_ :: CallSta
 --   You shouldn't call warning/error if the user has caused an error, only
 --   if our code has gone wrong and is itself erroneous (e.g. we threw an exception).
 newtype Recorder msg = Recorder
-  { logger_ :: forall m. (MonadUnliftIO m) => msg -> m () }
+  { logger_ :: forall m. (MonadIO m) => msg -> m () }
 
-logWith :: (HasCallStack, MonadUnliftIO m) => Recorder (WithPriority msg) -> Priority -> msg -> m ()
+logWith :: (HasCallStack, MonadIO m) => Recorder (WithPriority msg) -> Priority -> msg -> m ()
 logWith recorder priority msg = withFrozenCallStack $ logger_ recorder (WithPriority priority callStack msg)
 
 instance Semigroup (Recorder msg) where

diff --git a/hls-graph/hls-graph.cabal b/hls-graph/hls-graph.cabal
@@ -81,7 +81,6 @@ library
     , stm-containers
     , time
     , transformers
-    , unliftio
     , unordered-containers
 
   if flag(embed-files)

diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Types.hs b/hls-graph/src/Development/IDE/Graph/Internal/Types.hs
@@ -36,7 +36,6 @@ import qualified ListT
 import           StmContainers.Map             (Map)
 import qualified StmContainers.Map             as SMap
 import           System.Time.Extra             (Seconds)
-import UnliftIO (MonadUnliftIO)
 
 
 unwrapDynamic :: forall a . Typeable a => Dynamic -> a
@@ -63,7 +62,7 @@ data SRules = SRules {
 -- ACTIONS
 
 newtype Action a = Action {fromAction :: ReaderT SAction IO a}
-    deriving newtype (Monad, Applicative, Functor, MonadIO, MonadFail, MonadThrow, MonadCatch, MonadMask, MonadUnliftIO)
+    deriving newtype (Monad, Applicative, Functor, MonadIO, MonadFail, MonadThrow, MonadCatch, MonadMask)
 
 data SAction = SAction {
     actionDatabase :: !Database,