{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE ScopedTypeVariables       #-}
{-# 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