{-# LANGUAGE CPP                       #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE ScopedTypeVariables       #-}
{-# LANGUAGE TypeApplications          #-}
{-# 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) <- 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)
    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 =
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. Logger -> Priority -> Text -> IO ()
logPriority (IdeState -> Logger
ideLogger IdeState
state) Priority
logLevel forall a b. (a -> b) -> a -> b
$
        [Text] -> Text
T.unwords
            [String -> Text
T.pack String
logWithPos, forall a. Show a => a -> Text
asT a1
key, forall a. Show a => a -> Text
asT a2
val]
  where
    logWithPos :: String
logWithPos =
        let stk :: [Item CallStack]
stk = forall l. IsList l => l -> [Item l]
toList HasCallStack => CallStack
callStack
            pr :: SrcLoc -> String
pr SrcLoc
pos = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [SrcLoc -> String
srcLocFile SrcLoc
pos, String
":", forall a. Show a => a -> String
show forall b c a. (b -> c) -> (a -> b) -> a -> c
. SrcLoc -> Int
srcLocStartLine forall a b. (a -> b) -> a -> b
$ SrcLoc
pos, String
":", forall a. Show a => a -> String
show forall b c a. (b -> c) -> (a -> b) -> a -> c
. SrcLoc -> Int
srcLocStartCol forall a b. (a -> b) -> a -> b
$ SrcLoc
pos]
         in if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(String, SrcLoc)]
stk then String
"" else SrcLoc -> String
pr forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> a
head forall a b. (a -> b) -> a -> b
$ [(String, SrcLoc)]
stk

    asT :: Show a => a -> T.Text
    asT :: forall a. Show a => a -> Text
asT = String -> Text
T.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 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 <-  forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT ExceptT PluginError (LspM c) WorkspaceEdit
act
             forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> (SomeException -> m a) -> m a
`catchAny` \SomeException
e -> do
                String
res <- forall (m :: * -> *). Monad m => SomeException -> m String
showErr SomeException
e
                forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> Either a b
Left  forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> PluginError
PluginInternalError forall a b. (a -> b) -> a -> b
$ forall a. IsString a => String -> a
fromString String
res)
    LspId 'Method_WorkspaceApplyEdit
_ <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: Method 'ServerToClient 'Request) (f :: * -> *) config.
MonadLsp config f =>
SServerMethod m
-> MessageParams m
-> (Either ResponseError (MessageResult m) -> f ())
-> f (LspId m)
sendRequest SMethod 'Method_WorkspaceApplyEdit
SMethod_WorkspaceApplyEdit (Maybe Text -> WorkspaceEdit -> ApplyWorkspaceEditParams
ApplyWorkspaceEditParams forall a. Maybe a
Nothing WorkspaceEdit
res) (\Either ResponseError (MessageResult 'Method_WorkspaceApplyEdit)
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ 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 =
    forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
catch
        (m b
op forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. b -> Either a b
Right forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. MonadIO m => a -> m a
gevaluate)
        (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. a -> Either a b
Left forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). Monad m => SomeException -> m String
showErr)

gevaluate :: MonadIO m => a -> m a
gevaluate :: forall (m :: * -> *) a. MonadIO m => a -> m a
gevaluate = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 fromException 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 msgs) -> return $ renderWithContext defaultSDocContext
                                      $ vcat
                                      $ bagToList
                                      $ fmap (vcat . unDecorated
                                                   . diagnosticMessage
#if MIN_VERSION_ghc(9,5,0)
                                                    (defaultDiagnosticOpts @GhcMessage)
#endif
                                                   . errMsgDiagnostic)
                                      $ getMessages msgs
    _ ->
#endif
      forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show forall a b. (a -> b) -> a -> b
$ SomeException
e