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