1{-# LANGUAGE NoMonomorphismRestriction #-}
2{-# LANGUAGE ScopedTypeVariables       #-}
3{-# OPTIONS_GHC -Wno-orphans #-}
4
5-- |Debug utilities
6module Ide.Plugin.Eval.Util (
7    asS,
8    timed,
9    isLiterate,
10    handleMaybe,
11    handleMaybeM,
12    response,
13    response',
14    gStrictTry,
15    logWith,
16) where
17
18import           Control.Monad.Extra        (maybeM)
19import           Control.Monad.IO.Class     (MonadIO (liftIO))
20import           Control.Monad.Trans.Class  (lift)
21import           Control.Monad.Trans.Except (ExceptT (..), runExceptT, throwE)
22import           Data.Aeson                 (Value (Null))
23import           Data.Bifunctor             (first)
24import           Data.String                (IsString (fromString))
25import qualified Data.Text                  as T
26import           Development.IDE            (IdeState, Priority (..), ideLogger,
27                                             logPriority)
28import           Development.IDE.GHC.Compat (gcatch)
29import           Exception                  (ExceptionMonad, SomeException (..),
30                                             evaluate)
31import           GHC.Exts                   (toList)
32import           GHC.Stack                  (HasCallStack, callStack,
33                                             srcLocFile, srcLocStartCol,
34                                             srcLocStartLine)
35import           Language.LSP.Server
36import           Language.LSP.Types
37import           Outputable                 (Outputable (ppr), ppr,
38                                             showSDocUnsafe)
39import           System.FilePath            (takeExtension)
40import           System.Time.Extra          (duration, showDuration)
41import           UnliftIO.Exception         (catchAny)
42
43asS :: Outputable a => a -> String
44asS = showSDocUnsafe . ppr
45
46timed :: MonadIO m => (t -> String -> m a) -> t -> m b -> m b
47timed out name op = do
48    (secs, r) <- duration op
49    _ <- out name (showDuration secs)
50    return r
51
52-- |Log using hie logger, reports source position of logging statement
53logWith :: (HasCallStack, MonadIO m, Show a1, Show a2) => IdeState -> a1 -> a2 -> m ()
54logWith state key val =
55    liftIO . logPriority (ideLogger state) logLevel $
56        T.unwords
57            [T.pack logWithPos, asT key, asT val]
58  where
59    logWithPos =
60        let stk = toList callStack
61            pr pos = concat [srcLocFile pos, ":", show . srcLocStartLine $ pos, ":", show . srcLocStartCol $ pos]
62         in if null stk then "" else pr . snd . head $ stk
63
64    asT :: Show a => a -> T.Text
65    asT = T.pack . show
66
67-- | Set to Info to see extensive debug info in hie log, set to Debug in production
68logLevel :: Priority
69logLevel = Debug -- Info
70
71isLiterate :: FilePath -> Bool
72isLiterate x = takeExtension x `elem` [".lhs", ".lhs-boot"]
73
74handleMaybe :: Monad m => e -> Maybe b -> ExceptT e m b
75handleMaybe msg = maybe (throwE msg) return
76
77handleMaybeM :: Monad m => e -> m (Maybe b) -> ExceptT e m b
78handleMaybeM msg act = maybeM (throwE msg) return $ lift act
79
80response :: Functor f => ExceptT String f c -> f (Either ResponseError c)
81response =
82    fmap (first (\msg -> ResponseError InternalError (fromString msg) Nothing))
83        . runExceptT
84
85response' :: ExceptT String (LspM c) WorkspaceEdit -> LspM c (Either ResponseError Value)
86response' act = do
87    res <- runExceptT act
88             `catchAny` showErr
89    case res of
90      Left e ->
91          return $ Left (ResponseError InternalError (fromString e) Nothing)
92      Right a -> do
93        _ <- sendRequest SWorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing a) (\_ -> pure ())
94        return $ Right Null
95
96gStrictTry :: ExceptionMonad m => m b -> m (Either String b)
97gStrictTry op =
98    gcatch
99        (op >>= fmap Right . gevaluate)
100        showErr
101
102gevaluate :: MonadIO m => a -> m a
103gevaluate = liftIO . evaluate
104
105showErr :: Monad m => SomeException -> m (Either String b)
106showErr = return . Left . show
107