{-# LANGUAGE CPP                       #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
{-# OPTIONS_GHC -Wno-orphans -Wno-unused-imports #-}

-- |Debug utilities
module Ide.Plugin.Eval.Util (
    timed,
    isLiterate,
    response',
    gStrictTry,
    logWith,
) where

import           Control.Exception                     (SomeException, evaluate,
                                                        fromException)
import           Control.Monad.Error.Class             (MonadError (throwError))
import           Control.Monad.IO.Class                (MonadIO (liftIO))
import           Control.Monad.Trans.Class             (MonadTrans (lift))
import           Control.Monad.Trans.Except            (ExceptT (..),
                                                        runExceptT)
import           Data.Aeson                            (Value)
import           Data.Bifunctor                        (second)
import           Data.String                           (IsString (fromString))
import qualified Data.Text                             as T
import           Development.IDE                       (IdeState, Priority (..),
                                                        ideLogger, logPriority)
import qualified Development.IDE.Core.PluginUtils      as PluginUtils
import           Development.IDE.GHC.Compat.Outputable
import           Development.IDE.GHC.Compat.Util       (MonadCatch, bagToList,
                                                        catch)
import           GHC.Exts                              (toList)
import           GHC.Stack                             (HasCallStack, callStack,
                                                        srcLocFile,
                                                        srcLocStartCol,
                                                        srcLocStartLine)
import           Ide.Plugin.Error
import           Language.LSP.Protocol.Message
import           Language.LSP.Protocol.Types
import           Language.LSP.Server
import           System.FilePath                       (takeExtension)
import           System.Time.Extra                     (duration, showDuration)
import           UnliftIO.Exception                    (catchAny)

timed :: MonadIO m => (t -> String -> m a) -> t -> m b -> m b
timed :: forall (m :: * -> *) t a b.
MonadIO m =>
(t -> String -> m a) -> t -> m b -> m b
timed t -> String -> m a
out t
name m b
op = do
    (Seconds
secs, b
r) <- m b -> m (Seconds, b)
forall (m :: * -> *) a. MonadIO m => m a -> m (Seconds, a)
duration m b
op
    a
_ <- t -> String -> m a
out t
name (Seconds -> String
showDuration Seconds
secs)
    b -> m b
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return b
r

-- | Log using hie logger, reports source position of logging statement
logWith :: (HasCallStack, MonadIO m, Show a1, Show a2) => IdeState -> a1 -> a2 -> m ()
logWith :: forall (m :: * -> *) a1 a2.
(HasCallStack, MonadIO m, Show a1, Show a2) =>
IdeState -> a1 -> a2 -> m ()
logWith IdeState
state a1
key a2
val =
    IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> (Text -> IO ()) -> Text -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Logger -> Priority -> Text -> IO ()
logPriority (IdeState -> Logger
ideLogger IdeState
state) Priority
logLevel (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$
        [Text] -> Text
T.unwords
            [String -> Text
T.pack String
logWithPos, a1 -> Text
forall a. Show a => a -> Text
asT a1
key, a2 -> Text
forall a. Show a => a -> Text
asT a2
val]
  where
    logWithPos :: String
logWithPos =
        let stk :: [Item CallStack]
stk = CallStack -> [Item CallStack]
forall l. IsList l => l -> [Item l]
toList CallStack
HasCallStack => CallStack
callStack
            pr :: SrcLoc -> String
pr SrcLoc
pos = [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [SrcLoc -> String
srcLocFile SrcLoc
pos, String
":", Int -> String
forall a. Show a => a -> String
show (Int -> String) -> (SrcLoc -> Int) -> SrcLoc -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SrcLoc -> Int
srcLocStartLine (SrcLoc -> String) -> SrcLoc -> String
forall a b. (a -> b) -> a -> b
$ SrcLoc
pos, String
":", Int -> String
forall a. Show a => a -> String
show (Int -> String) -> (SrcLoc -> Int) -> SrcLoc -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SrcLoc -> Int
srcLocStartCol (SrcLoc -> String) -> SrcLoc -> String
forall a b. (a -> b) -> a -> b
$ SrcLoc
pos]
         in case [(String, SrcLoc)]
stk of
              []    -> String
""
              ((String, SrcLoc)
x:[(String, SrcLoc)]
_) -> SrcLoc -> String
pr (SrcLoc -> String) -> SrcLoc -> String
forall a b. (a -> b) -> a -> b
$ (String, SrcLoc) -> SrcLoc
forall a b. (a, b) -> b
snd (String, SrcLoc)
x

    asT :: Show a => a -> T.Text
    asT :: forall a. Show a => a -> Text
asT = String -> Text
T.pack (String -> Text) -> (a -> String) -> a -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> String
forall a. Show a => a -> String
show

-- | Set to Info to see extensive debug info in hie log, set to Debug in production
logLevel :: Priority
logLevel :: Priority
logLevel = Priority
Debug -- Info

isLiterate :: FilePath -> Bool
isLiterate :: String -> Bool
isLiterate String
x = String -> String
takeExtension String
x String -> [String] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String
".lhs", String
".lhs-boot"]

response' :: ExceptT PluginError (LspM c) WorkspaceEdit -> ExceptT PluginError (LspM c) (Value |? Null)
response' :: forall c.
ExceptT PluginError (LspM c) WorkspaceEdit
-> ExceptT PluginError (LspM c) (Value |? Null)
response' ExceptT PluginError (LspM c) WorkspaceEdit
act = do
    WorkspaceEdit
res <-  LspM c (Either PluginError WorkspaceEdit)
-> ExceptT PluginError (LspM c) WorkspaceEdit
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (ExceptT PluginError (LspM c) WorkspaceEdit
-> LspM c (Either PluginError WorkspaceEdit)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT ExceptT PluginError (LspM c) WorkspaceEdit
act
             LspM c (Either PluginError WorkspaceEdit)
-> (SomeException -> LspM c (Either PluginError WorkspaceEdit))
-> LspM c (Either PluginError WorkspaceEdit)
forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> (SomeException -> m a) -> m a
`catchAny` \SomeException
e -> do
                String
res <- SomeException -> LspM c String
forall (m :: * -> *). Monad m => SomeException -> m String
showErr SomeException
e
                Either PluginError WorkspaceEdit
-> LspM c (Either PluginError WorkspaceEdit)
forall a. a -> LspT c IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either PluginError WorkspaceEdit
 -> LspM c (Either PluginError WorkspaceEdit))
-> (Text -> Either PluginError WorkspaceEdit)
-> Text
-> LspM c (Either PluginError WorkspaceEdit)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PluginError -> Either PluginError WorkspaceEdit
forall a b. a -> Either a b
Left  (PluginError -> Either PluginError WorkspaceEdit)
-> (Text -> PluginError)
-> Text
-> Either PluginError WorkspaceEdit
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> PluginError
PluginInternalError (Text -> LspM c (Either PluginError WorkspaceEdit))
-> Text -> LspM c (Either PluginError WorkspaceEdit)
forall a b. (a -> b) -> a -> b
$ String -> Text
forall a. IsString a => String -> a
fromString String
res)
    LspId 'Method_WorkspaceApplyEdit
_ <- LspM c (LspId 'Method_WorkspaceApplyEdit)
-> ExceptT PluginError (LspM c) (LspId 'Method_WorkspaceApplyEdit)
forall (m :: * -> *) a. Monad m => m a -> ExceptT PluginError m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (LspM c (LspId 'Method_WorkspaceApplyEdit)
 -> ExceptT PluginError (LspM c) (LspId 'Method_WorkspaceApplyEdit))
-> LspM c (LspId 'Method_WorkspaceApplyEdit)
-> ExceptT PluginError (LspM c) (LspId 'Method_WorkspaceApplyEdit)
forall a b. (a -> b) -> a -> b
$ SServerMethod 'Method_WorkspaceApplyEdit
-> MessageParams 'Method_WorkspaceApplyEdit
-> (Either ResponseError (MessageResult 'Method_WorkspaceApplyEdit)
    -> LspT c IO ())
-> LspM c (LspId 'Method_WorkspaceApplyEdit)
forall (m :: Method 'ServerToClient 'Request) (f :: * -> *) config.
MonadLsp config f =>
SServerMethod m
-> MessageParams m
-> (Either ResponseError (MessageResult m) -> f ())
-> f (LspId m)
sendRequest SServerMethod 'Method_WorkspaceApplyEdit
SMethod_WorkspaceApplyEdit (Maybe Text -> WorkspaceEdit -> ApplyWorkspaceEditParams
ApplyWorkspaceEditParams Maybe Text
forall a. Maybe a
Nothing WorkspaceEdit
res) (\Either ResponseError (MessageResult 'Method_WorkspaceApplyEdit)
_ -> () -> LspT c IO ()
forall a. a -> LspT c IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
    (Value |? Null) -> ExceptT PluginError (LspM c) (Value |? Null)
forall a. a -> ExceptT PluginError (LspM c) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Value |? Null) -> ExceptT PluginError (LspM c) (Value |? Null))
-> (Value |? Null) -> ExceptT PluginError (LspM c) (Value |? Null)
forall a b. (a -> b) -> a -> b
$ Null -> Value |? Null
forall a b. b -> a |? b
InR Null
Null

gStrictTry :: (MonadIO m, MonadCatch m) => m b -> m (Either String b)
gStrictTry :: forall (m :: * -> *) b.
(MonadIO m, MonadCatch m) =>
m b -> m (Either String b)
gStrictTry m b
op =
    m (Either String b)
-> (SomeException -> m (Either String b)) -> m (Either String b)
forall (m :: * -> *) e a.
(HasCallStack, MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
catch
        (m b
op m b -> (b -> m (Either String b)) -> m (Either String b)
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (b -> Either String b) -> m b -> m (Either String b)
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap b -> Either String b
forall a b. b -> Either a b
Right (m b -> m (Either String b))
-> (b -> m b) -> b -> m (Either String b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. b -> m b
forall (m :: * -> *) a. MonadIO m => a -> m a
gevaluate)
        ((String -> Either String b) -> m String -> m (Either String b)
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> Either String b
forall a b. a -> Either a b
Left (m String -> m (Either String b))
-> (SomeException -> m String)
-> SomeException
-> m (Either String b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SomeException -> m String
forall (m :: * -> *). Monad m => SomeException -> m String
showErr)

gevaluate :: MonadIO m => a -> m a
gevaluate :: forall (m :: * -> *) a. MonadIO m => a -> m a
gevaluate = IO a -> m a
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> m a) -> (a -> IO a) -> a -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> IO a
forall a. a -> IO a
evaluate

showErr :: Monad m => SomeException -> m String
showErr :: forall (m :: * -> *). Monad m => SomeException -> m String
showErr SomeException
e =
#if MIN_VERSION_ghc(9,3,0)
  case SomeException -> Maybe SourceError
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e of
    -- On GHC 9.4+, the show instance adds the error message span
    -- We don't want this for the plugin
    -- So render without the span.
    Just (SourceError Messages GhcMessage
msgs) -> String -> m String
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> m String) -> String -> m String
forall a b. (a -> b) -> a -> b
$ SDocContext -> SDoc -> String
renderWithContext SDocContext
defaultSDocContext
                                      (SDoc -> String) -> SDoc -> String
forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat
                                      ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall a b. (a -> b) -> a -> b
$ Bag SDoc -> [SDoc]
forall a. Bag a -> [a]
bagToList
                                      (Bag SDoc -> [SDoc]) -> Bag SDoc -> [SDoc]
forall a b. (a -> b) -> a -> b
$ (MsgEnvelope GhcMessage -> SDoc)
-> Bag (MsgEnvelope GhcMessage) -> Bag SDoc
forall a b. (a -> b) -> Bag a -> Bag b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat ([SDoc] -> SDoc)
-> (MsgEnvelope GhcMessage -> [SDoc])
-> MsgEnvelope GhcMessage
-> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DecoratedSDoc -> [SDoc]
unDecorated
                                                   (DecoratedSDoc -> [SDoc])
-> (MsgEnvelope GhcMessage -> DecoratedSDoc)
-> MsgEnvelope GhcMessage
-> [SDoc]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DiagnosticOpts GhcMessage -> GhcMessage -> DecoratedSDoc
forall a. Diagnostic a => DiagnosticOpts a -> a -> DecoratedSDoc
diagnosticMessage
#if MIN_VERSION_ghc(9,5,0)
                                                    (forall a. Diagnostic a => DiagnosticOpts a
defaultDiagnosticOpts @GhcMessage)
#endif
                                                   (GhcMessage -> DecoratedSDoc)
-> (MsgEnvelope GhcMessage -> GhcMessage)
-> MsgEnvelope GhcMessage
-> DecoratedSDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MsgEnvelope GhcMessage -> GhcMessage
forall e. MsgEnvelope e -> e
errMsgDiagnostic)
                                      (Bag (MsgEnvelope GhcMessage) -> Bag SDoc)
-> Bag (MsgEnvelope GhcMessage) -> Bag SDoc
forall a b. (a -> b) -> a -> b
$ Messages GhcMessage -> Bag (MsgEnvelope GhcMessage)
forall e. Messages e -> Bag (MsgEnvelope e)
getMessages Messages GhcMessage
msgs
    Maybe SourceError
_ ->
#endif
      String -> m String
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> m String)
-> (SomeException -> String) -> SomeException -> m String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SomeException -> String
forall a. Show a => a -> String
show (SomeException -> m String) -> SomeException -> m String
forall a b. (a -> b) -> a -> b
$ SomeException
e