{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
{-# OPTIONS_GHC -Wno-orphans #-}

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

import Control.Monad.Extra (maybeM)
import Control.Monad.IO.Class (MonadIO (liftIO))
import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.Except (
    ExceptT (..),
    runExceptT,
    throwE,
 )
import Data.Aeson (Value (Null))
import Data.Bifunctor (first)
import Data.String (IsString (fromString))
import qualified Data.Text as T
import Development.IDE (
    IdeState,
    Priority (..),
    ideLogger,
    logPriority,
 )
import Exception (ExceptionMonad, SomeException (..), evaluate, gcatch)
import GHC.Exts (toList)
import GHC.Stack (HasCallStack, callStack, srcLocFile, srcLocStartCol, srcLocStartLine)
import Language.LSP.Server
import Language.LSP.Types
import Outputable (
    Outputable (ppr),
    ppr,
    showSDocUnsafe,
 )
import System.FilePath (takeExtension)
import System.Time.Extra (
    duration,
    showDuration,
 )
import UnliftIO.Exception (catchAny)

asS :: Outputable a => a -> String
asS :: a -> String
asS = SDoc -> String
showSDocUnsafe (SDoc -> String) -> (a -> SDoc) -> a -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> SDoc
forall a. Outputable a => a -> SDoc
ppr

timed :: MonadIO m => (t -> String -> m a) -> t -> m b -> m b
timed :: (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 (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 :: IdeState -> a1 -> a2 -> m ()
logWith IdeState
state a1
key a2
val =
    IO () -> m ()
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 if [(String, SrcLoc)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(String, SrcLoc)]
stk then String
"" else SrcLoc -> String
pr (SrcLoc -> String)
-> ([(String, SrcLoc)] -> SrcLoc) -> [(String, SrcLoc)] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String, SrcLoc) -> SrcLoc
forall a b. (a, b) -> b
snd ((String, SrcLoc) -> SrcLoc)
-> ([(String, SrcLoc)] -> (String, SrcLoc))
-> [(String, SrcLoc)]
-> SrcLoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(String, SrcLoc)] -> (String, SrcLoc)
forall a. [a] -> a
head ([(String, SrcLoc)] -> String) -> [(String, SrcLoc)] -> String
forall a b. (a -> b) -> a -> b
$ [(String, SrcLoc)]
stk

    asT :: Show a => a -> T.Text
    asT :: 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 (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String
".lhs", String
".lhs-boot"]

handleMaybe :: Monad m => e -> Maybe b -> ExceptT e m b
handleMaybe :: e -> Maybe b -> ExceptT e m b
handleMaybe e
msg = ExceptT e m b -> (b -> ExceptT e m b) -> Maybe b -> ExceptT e m b
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (e -> ExceptT e m b
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE e
msg) b -> ExceptT e m b
forall (m :: * -> *) a. Monad m => a -> m a
return

handleMaybeM :: Monad m => e -> m (Maybe b) -> ExceptT e m b
handleMaybeM :: e -> m (Maybe b) -> ExceptT e m b
handleMaybeM e
msg m (Maybe b)
act = ExceptT e m b
-> (b -> ExceptT e m b) -> ExceptT e m (Maybe b) -> ExceptT e m b
forall (m :: * -> *) b a.
Monad m =>
m b -> (a -> m b) -> m (Maybe a) -> m b
maybeM (e -> ExceptT e m b
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE e
msg) b -> ExceptT e m b
forall (m :: * -> *) a. Monad m => a -> m a
return (ExceptT e m (Maybe b) -> ExceptT e m b)
-> ExceptT e m (Maybe b) -> ExceptT e m b
forall a b. (a -> b) -> a -> b
$ m (Maybe b) -> ExceptT e m (Maybe b)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m (Maybe b)
act

response :: Functor f => ExceptT String f c -> f (Either ResponseError c)
response :: ExceptT String f c -> f (Either ResponseError c)
response =
    (Either String c -> Either ResponseError c)
-> f (Either String c) -> f (Either ResponseError c)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((String -> ResponseError)
-> Either String c -> Either ResponseError c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (\String
msg -> ErrorCode -> Text -> Maybe Value -> ResponseError
ResponseError ErrorCode
InternalError (String -> Text
forall a. IsString a => String -> a
fromString String
msg) Maybe Value
forall a. Maybe a
Nothing))
        (f (Either String c) -> f (Either ResponseError c))
-> (ExceptT String f c -> f (Either String c))
-> ExceptT String f c
-> f (Either ResponseError c)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExceptT String f c -> f (Either String c)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT

response' :: ExceptT String (LspM c) WorkspaceEdit -> LspM c (Either ResponseError Value)
response' :: ExceptT String (LspM c) WorkspaceEdit
-> LspM c (Either ResponseError Value)
response' ExceptT String (LspM c) WorkspaceEdit
act = do
    Either String WorkspaceEdit
res <- ExceptT String (LspM c) WorkspaceEdit
-> LspM c (Either String WorkspaceEdit)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT ExceptT String (LspM c) WorkspaceEdit
act
             LspM c (Either String WorkspaceEdit)
-> (SomeException -> LspM c (Either String WorkspaceEdit))
-> LspM c (Either String WorkspaceEdit)
forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> (SomeException -> m a) -> m a
`catchAny` SomeException -> LspM c (Either String WorkspaceEdit)
forall (m :: * -> *) b.
Monad m =>
SomeException -> m (Either String b)
showErr
    case Either String WorkspaceEdit
res of
      Left String
e ->
          Either ResponseError Value -> LspM c (Either ResponseError Value)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either ResponseError Value -> LspM c (Either ResponseError Value))
-> Either ResponseError Value
-> LspM c (Either ResponseError Value)
forall a b. (a -> b) -> a -> b
$ ResponseError -> Either ResponseError Value
forall a b. a -> Either a b
Left (ErrorCode -> Text -> Maybe Value -> ResponseError
ResponseError ErrorCode
InternalError (String -> Text
forall a. IsString a => String -> a
fromString String
e) Maybe Value
forall a. Maybe a
Nothing)
      Right WorkspaceEdit
a -> do
        LspId 'WorkspaceApplyEdit
_ <- SServerMethod 'WorkspaceApplyEdit
-> MessageParams 'WorkspaceApplyEdit
-> (Either ResponseError (ResponseResult 'WorkspaceApplyEdit)
    -> LspT c IO ())
-> LspT c IO (LspId 'WorkspaceApplyEdit)
forall (m :: Method 'FromServer 'Request) (f :: * -> *) config.
MonadLsp config f =>
SServerMethod m
-> MessageParams m
-> (Either ResponseError (ResponseResult m) -> f ())
-> f (LspId m)
sendRequest SServerMethod 'WorkspaceApplyEdit
SWorkspaceApplyEdit (Maybe Text -> WorkspaceEdit -> ApplyWorkspaceEditParams
ApplyWorkspaceEditParams Maybe Text
forall a. Maybe a
Nothing WorkspaceEdit
a) (\Either ResponseError (ResponseResult 'WorkspaceApplyEdit)
_ -> () -> LspT c IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
        Either ResponseError Value -> LspM c (Either ResponseError Value)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either ResponseError Value -> LspM c (Either ResponseError Value))
-> Either ResponseError Value
-> LspM c (Either ResponseError Value)
forall a b. (a -> b) -> a -> b
$ Value -> Either ResponseError Value
forall a b. b -> Either a b
Right Value
Null

gStrictTry :: ExceptionMonad m => m b -> m (Either String b)
gStrictTry :: 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.
(ExceptionMonad m, Exception e) =>
m a -> (e -> m a) -> m a
gcatch
        (m b
op m b -> (b -> m (Either String b)) -> m (Either String 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 (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)
        SomeException -> m (Either String b)
forall (m :: * -> *) b.
Monad m =>
SomeException -> m (Either String b)
showErr

gevaluate :: MonadIO m => a -> m a
gevaluate :: a -> m a
gevaluate = 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 (Either String b)
showErr :: SomeException -> m (Either String b)
showErr = Either String b -> m (Either String b)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String b -> m (Either String b))
-> (SomeException -> Either String b)
-> SomeException
-> m (Either String b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Either String b
forall a b. a -> Either a b
Left (String -> Either String b)
-> (SomeException -> String) -> SomeException -> Either String b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SomeException -> String
forall a. Show a => a -> String
show