{-# LANGUAGE GADTs #-}
module Development.IDE.Core.PluginUtils
(-- * Wrapped Action functions
  runActionE
, runActionMT
, useE
, useMT
, usesE
, usesMT
, useWithStaleE
, useWithStaleMT
-- * Wrapped IdeAction functions
, runIdeActionE
, runIdeActionMT
, useWithStaleFastE
, useWithStaleFastMT
, uriToFilePathE
-- * Wrapped PositionMapping functions
, toCurrentPositionE
, toCurrentPositionMT
, fromCurrentPositionE
, fromCurrentPositionMT
, toCurrentRangeE
, toCurrentRangeMT
, fromCurrentRangeE
, fromCurrentRangeMT
-- * Diagnostics
, activeDiagnosticsInRange
, activeDiagnosticsInRangeMT
-- * Formatting handlers
, mkFormattingHandlers) where

import           Control.Concurrent.STM
import           Control.Lens                         ((^.))
import           Control.Monad.Error.Class            (MonadError (throwError))
import           Control.Monad.Extra
import           Control.Monad.IO.Class
import           Control.Monad.Reader                 (runReaderT)
import           Control.Monad.Trans.Except
import           Control.Monad.Trans.Maybe
import           Data.Functor.Identity
import qualified Data.Text                            as T
import qualified Data.Text.Utf16.Rope.Mixed           as Rope
import           Development.IDE.Core.FileStore
import           Development.IDE.Core.PositionMapping
import           Development.IDE.Core.Service         (runAction)
import           Development.IDE.Core.Shake           (IdeAction, IdeRule,
                                                       IdeState (shakeExtras),
                                                       mkDelayedAction,
                                                       shakeEnqueue)
import qualified Development.IDE.Core.Shake           as Shake
import           Development.IDE.GHC.Orphans          ()
import           Development.IDE.Graph                hiding (ShakeValue)
import           Development.IDE.Types.Diagnostics
import           Development.IDE.Types.Location       (NormalizedFilePath)
import qualified Development.IDE.Types.Location       as Location
import qualified Ide.Logger                           as Logger
import           Ide.Plugin.Error
import           Ide.PluginUtils                      (rangesOverlap)
import           Ide.Types
import qualified Language.LSP.Protocol.Lens           as LSP
import           Language.LSP.Protocol.Message        (SMethod (..))
import qualified Language.LSP.Protocol.Types          as LSP
import qualified StmContainers.Map                    as STM

-- ----------------------------------------------------------------------------
-- Action wrappers
-- ----------------------------------------------------------------------------

-- |ExceptT version of `runAction`, takes a ExceptT Action
runActionE :: MonadIO m => String -> IdeState -> ExceptT e Action a -> ExceptT e m a
runActionE :: forall (m :: * -> *) e a.
MonadIO m =>
String -> IdeState -> ExceptT e Action a -> ExceptT e m a
runActionE String
herald IdeState
ide ExceptT e Action a
act =
  (IO (Either e a) -> m (Either e a))
-> ExceptT e IO a -> ExceptT e m a
forall (m :: * -> *) e a (n :: * -> *) e' b.
(m (Either e a) -> n (Either e' b))
-> ExceptT e m a -> ExceptT e' n b
mapExceptT IO (Either e a) -> m (Either e a)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (ExceptT e IO a -> ExceptT e m a)
-> (IO (Either e a) -> ExceptT e IO a)
-> IO (Either e a)
-> ExceptT e m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO (Either e a) -> ExceptT e IO a
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (IO (Either e a) -> ExceptT e m a)
-> IO (Either e a) -> ExceptT e m a
forall a b. (a -> b) -> a -> b
$
    IO (IO (Either e a)) -> IO (Either e a)
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (IO (IO (Either e a)) -> IO (Either e a))
-> IO (IO (Either e a)) -> IO (Either e a)
forall a b. (a -> b) -> a -> b
$ ShakeExtras -> DelayedAction (Either e a) -> IO (IO (Either e a))
forall a. ShakeExtras -> DelayedAction a -> IO (IO a)
shakeEnqueue (IdeState -> ShakeExtras
shakeExtras IdeState
ide) (String
-> Priority -> Action (Either e a) -> DelayedAction (Either e a)
forall a. String -> Priority -> Action a -> DelayedAction a
mkDelayedAction String
herald Priority
Logger.Debug (Action (Either e a) -> DelayedAction (Either e a))
-> Action (Either e a) -> DelayedAction (Either e a)
forall a b. (a -> b) -> a -> b
$ ExceptT e Action a -> Action (Either e a)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT ExceptT e Action a
act)

-- |MaybeT version of `runAction`, takes a MaybeT Action
runActionMT :: MonadIO m => String -> IdeState -> MaybeT Action a -> MaybeT m a
runActionMT :: forall (m :: * -> *) a.
MonadIO m =>
String -> IdeState -> MaybeT Action a -> MaybeT m a
runActionMT String
herald IdeState
ide MaybeT Action a
act =
  (IO (Maybe a) -> m (Maybe a)) -> MaybeT IO a -> MaybeT m a
forall (m :: * -> *) a (n :: * -> *) b.
(m (Maybe a) -> n (Maybe b)) -> MaybeT m a -> MaybeT n b
mapMaybeT IO (Maybe a) -> m (Maybe a)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (MaybeT IO a -> MaybeT m a)
-> (IO (Maybe a) -> MaybeT IO a) -> IO (Maybe a) -> MaybeT m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO (Maybe a) -> MaybeT IO a
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (IO (Maybe a) -> MaybeT m a) -> IO (Maybe a) -> MaybeT m a
forall a b. (a -> b) -> a -> b
$
    IO (IO (Maybe a)) -> IO (Maybe a)
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (IO (IO (Maybe a)) -> IO (Maybe a))
-> IO (IO (Maybe a)) -> IO (Maybe a)
forall a b. (a -> b) -> a -> b
$ ShakeExtras -> DelayedAction (Maybe a) -> IO (IO (Maybe a))
forall a. ShakeExtras -> DelayedAction a -> IO (IO a)
shakeEnqueue (IdeState -> ShakeExtras
shakeExtras IdeState
ide) (String -> Priority -> Action (Maybe a) -> DelayedAction (Maybe a)
forall a. String -> Priority -> Action a -> DelayedAction a
mkDelayedAction String
herald Priority
Logger.Debug (Action (Maybe a) -> DelayedAction (Maybe a))
-> Action (Maybe a) -> DelayedAction (Maybe a)
forall a b. (a -> b) -> a -> b
$ MaybeT Action a -> Action (Maybe a)
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT MaybeT Action a
act)

-- |ExceptT version of `use` that throws a PluginRuleFailed upon failure
useE :: IdeRule k v => k -> NormalizedFilePath -> ExceptT PluginError Action v
useE :: forall k v.
IdeRule k v =>
k -> NormalizedFilePath -> ExceptT PluginError Action v
useE k
k = PluginError -> MaybeT Action v -> ExceptT PluginError Action v
forall (m :: * -> *) e a.
Functor m =>
e -> MaybeT m a -> ExceptT e m a
maybeToExceptT (Text -> PluginError
PluginRuleFailed (String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ k -> String
forall a. Show a => a -> String
show k
k)) (MaybeT Action v -> ExceptT PluginError Action v)
-> (NormalizedFilePath -> MaybeT Action v)
-> NormalizedFilePath
-> ExceptT PluginError Action v
forall b c a. (b -> c) -> (a -> b) -> a -> c
. k -> NormalizedFilePath -> MaybeT Action v
forall k v.
IdeRule k v =>
k -> NormalizedFilePath -> MaybeT Action v
useMT k
k

-- |MaybeT version of `use`
useMT :: IdeRule k v => k -> NormalizedFilePath -> MaybeT Action v
useMT :: forall k v.
IdeRule k v =>
k -> NormalizedFilePath -> MaybeT Action v
useMT k
k = Action (Maybe v) -> MaybeT Action v
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (Action (Maybe v) -> MaybeT Action v)
-> (NormalizedFilePath -> Action (Maybe v))
-> NormalizedFilePath
-> MaybeT Action v
forall b c a. (b -> c) -> (a -> b) -> a -> c
. k -> NormalizedFilePath -> Action (Maybe v)
forall k v.
IdeRule k v =>
k -> NormalizedFilePath -> Action (Maybe v)
Shake.use k
k

-- |ExceptT version of `uses` that throws a PluginRuleFailed upon failure
usesE :: (Traversable f, IdeRule k v) => k -> f NormalizedFilePath -> ExceptT PluginError Action (f v)
usesE :: forall (f :: * -> *) k v.
(Traversable f, IdeRule k v) =>
k -> f NormalizedFilePath -> ExceptT PluginError Action (f v)
usesE k
k = PluginError
-> MaybeT Action (f v) -> ExceptT PluginError Action (f v)
forall (m :: * -> *) e a.
Functor m =>
e -> MaybeT m a -> ExceptT e m a
maybeToExceptT (Text -> PluginError
PluginRuleFailed (String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ k -> String
forall a. Show a => a -> String
show k
k)) (MaybeT Action (f v) -> ExceptT PluginError Action (f v))
-> (f NormalizedFilePath -> MaybeT Action (f v))
-> f NormalizedFilePath
-> ExceptT PluginError Action (f v)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. k -> f NormalizedFilePath -> MaybeT Action (f v)
forall (f :: * -> *) k v.
(Traversable f, IdeRule k v) =>
k -> f NormalizedFilePath -> MaybeT Action (f v)
usesMT k
k

-- |MaybeT version of `uses`
usesMT :: (Traversable f, IdeRule k v) => k -> f NormalizedFilePath -> MaybeT Action (f v)
usesMT :: forall (f :: * -> *) k v.
(Traversable f, IdeRule k v) =>
k -> f NormalizedFilePath -> MaybeT Action (f v)
usesMT k
k f NormalizedFilePath
xs = Action (Maybe (f v)) -> MaybeT Action (f v)
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (Action (Maybe (f v)) -> MaybeT Action (f v))
-> Action (Maybe (f v)) -> MaybeT Action (f v)
forall a b. (a -> b) -> a -> b
$ f (Maybe v) -> Maybe (f v)
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => f (m a) -> m (f a)
sequence (f (Maybe v) -> Maybe (f v))
-> Action (f (Maybe v)) -> Action (Maybe (f v))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> k -> f NormalizedFilePath -> Action (f (Maybe v))
forall (f :: * -> *) k v.
(Traversable f, IdeRule k v) =>
k -> f NormalizedFilePath -> Action (f (Maybe v))
Shake.uses k
k f NormalizedFilePath
xs

-- |ExceptT version of `useWithStale` that throws a PluginRuleFailed upon
-- failure
useWithStaleE :: IdeRule k v
    => k -> NormalizedFilePath -> ExceptT PluginError Action (v, PositionMapping)
useWithStaleE :: forall k v.
IdeRule k v =>
k
-> NormalizedFilePath
-> ExceptT PluginError Action (v, PositionMapping)
useWithStaleE k
key = PluginError
-> MaybeT Action (v, PositionMapping)
-> ExceptT PluginError Action (v, PositionMapping)
forall (m :: * -> *) e a.
Functor m =>
e -> MaybeT m a -> ExceptT e m a
maybeToExceptT (Text -> PluginError
PluginRuleFailed (String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ k -> String
forall a. Show a => a -> String
show k
key)) (MaybeT Action (v, PositionMapping)
 -> ExceptT PluginError Action (v, PositionMapping))
-> (NormalizedFilePath -> MaybeT Action (v, PositionMapping))
-> NormalizedFilePath
-> ExceptT PluginError Action (v, PositionMapping)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. k -> NormalizedFilePath -> MaybeT Action (v, PositionMapping)
forall k v.
IdeRule k v =>
k -> NormalizedFilePath -> MaybeT Action (v, PositionMapping)
useWithStaleMT k
key

-- |MaybeT version of `useWithStale`
useWithStaleMT :: IdeRule k v
    => k -> NormalizedFilePath -> MaybeT Action (v, PositionMapping)
useWithStaleMT :: forall k v.
IdeRule k v =>
k -> NormalizedFilePath -> MaybeT Action (v, PositionMapping)
useWithStaleMT k
key NormalizedFilePath
file = Action (Maybe (v, PositionMapping))
-> MaybeT Action (v, PositionMapping)
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (Action (Maybe (v, PositionMapping))
 -> MaybeT Action (v, PositionMapping))
-> Action (Maybe (v, PositionMapping))
-> MaybeT Action (v, PositionMapping)
forall a b. (a -> b) -> a -> b
$ Identity (Maybe (v, PositionMapping)) -> Maybe (v, PositionMapping)
forall a. Identity a -> a
runIdentity (Identity (Maybe (v, PositionMapping))
 -> Maybe (v, PositionMapping))
-> Action (Identity (Maybe (v, PositionMapping)))
-> Action (Maybe (v, PositionMapping))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> k
-> Identity NormalizedFilePath
-> Action (Identity (Maybe (v, PositionMapping)))
forall (f :: * -> *) k v.
(Traversable f, IdeRule k v) =>
k
-> f NormalizedFilePath -> Action (f (Maybe (v, PositionMapping)))
Shake.usesWithStale k
key (NormalizedFilePath -> Identity NormalizedFilePath
forall a. a -> Identity a
Identity NormalizedFilePath
file)

-- ----------------------------------------------------------------------------
-- IdeAction wrappers
-- ----------------------------------------------------------------------------

-- |ExceptT version of `runIdeAction`, takes a ExceptT IdeAction
runIdeActionE :: MonadIO m => String -> Shake.ShakeExtras -> ExceptT e IdeAction a -> ExceptT e m a
runIdeActionE :: forall (m :: * -> *) e a.
MonadIO m =>
String -> ShakeExtras -> ExceptT e IdeAction a -> ExceptT e m a
runIdeActionE String
_herald ShakeExtras
s ExceptT e IdeAction a
i = m (Either e a) -> ExceptT e m a
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (m (Either e a) -> ExceptT e m a)
-> m (Either e a) -> ExceptT e m a
forall a b. (a -> b) -> a -> b
$ IO (Either e a) -> m (Either e a)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either e a) -> m (Either e a))
-> IO (Either e a) -> m (Either e a)
forall a b. (a -> b) -> a -> b
$ ReaderT ShakeExtras IO (Either e a)
-> ShakeExtras -> IO (Either e a)
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (IdeAction (Either e a) -> ReaderT ShakeExtras IO (Either e a)
forall a. IdeAction a -> ReaderT ShakeExtras IO a
Shake.runIdeActionT (IdeAction (Either e a) -> ReaderT ShakeExtras IO (Either e a))
-> IdeAction (Either e a) -> ReaderT ShakeExtras IO (Either e a)
forall a b. (a -> b) -> a -> b
$ ExceptT e IdeAction a -> IdeAction (Either e a)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT ExceptT e IdeAction a
i) ShakeExtras
s

-- |MaybeT version of `runIdeAction`, takes a MaybeT IdeAction
runIdeActionMT :: MonadIO m => String -> Shake.ShakeExtras -> MaybeT IdeAction a -> MaybeT m a
runIdeActionMT :: forall (m :: * -> *) a.
MonadIO m =>
String -> ShakeExtras -> MaybeT IdeAction a -> MaybeT m a
runIdeActionMT String
_herald ShakeExtras
s MaybeT IdeAction a
i = m (Maybe a) -> MaybeT m a
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (m (Maybe a) -> MaybeT m a) -> m (Maybe a) -> MaybeT m a
forall a b. (a -> b) -> a -> b
$ IO (Maybe a) -> m (Maybe a)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe a) -> m (Maybe a)) -> IO (Maybe a) -> m (Maybe a)
forall a b. (a -> b) -> a -> b
$ ReaderT ShakeExtras IO (Maybe a) -> ShakeExtras -> IO (Maybe a)
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (IdeAction (Maybe a) -> ReaderT ShakeExtras IO (Maybe a)
forall a. IdeAction a -> ReaderT ShakeExtras IO a
Shake.runIdeActionT (IdeAction (Maybe a) -> ReaderT ShakeExtras IO (Maybe a))
-> IdeAction (Maybe a) -> ReaderT ShakeExtras IO (Maybe a)
forall a b. (a -> b) -> a -> b
$ MaybeT IdeAction a -> IdeAction (Maybe a)
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT MaybeT IdeAction a
i) ShakeExtras
s

-- |ExceptT version of `useWithStaleFast` that throws a PluginRuleFailed upon
-- failure
useWithStaleFastE :: IdeRule k v => k -> NormalizedFilePath -> ExceptT PluginError IdeAction (v, PositionMapping)
useWithStaleFastE :: forall k v.
IdeRule k v =>
k
-> NormalizedFilePath
-> ExceptT PluginError IdeAction (v, PositionMapping)
useWithStaleFastE k
k = PluginError
-> MaybeT IdeAction (v, PositionMapping)
-> ExceptT PluginError IdeAction (v, PositionMapping)
forall (m :: * -> *) e a.
Functor m =>
e -> MaybeT m a -> ExceptT e m a
maybeToExceptT (Text -> PluginError
PluginRuleFailed (String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ k -> String
forall a. Show a => a -> String
show k
k)) (MaybeT IdeAction (v, PositionMapping)
 -> ExceptT PluginError IdeAction (v, PositionMapping))
-> (NormalizedFilePath -> MaybeT IdeAction (v, PositionMapping))
-> NormalizedFilePath
-> ExceptT PluginError IdeAction (v, PositionMapping)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. k -> NormalizedFilePath -> MaybeT IdeAction (v, PositionMapping)
forall k v.
IdeRule k v =>
k -> NormalizedFilePath -> MaybeT IdeAction (v, PositionMapping)
useWithStaleFastMT k
k

-- |MaybeT version of `useWithStaleFast`
useWithStaleFastMT :: IdeRule k v => k -> NormalizedFilePath -> MaybeT IdeAction (v, PositionMapping)
useWithStaleFastMT :: forall k v.
IdeRule k v =>
k -> NormalizedFilePath -> MaybeT IdeAction (v, PositionMapping)
useWithStaleFastMT k
k = IdeAction (Maybe (v, PositionMapping))
-> MaybeT IdeAction (v, PositionMapping)
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (IdeAction (Maybe (v, PositionMapping))
 -> MaybeT IdeAction (v, PositionMapping))
-> (NormalizedFilePath -> IdeAction (Maybe (v, PositionMapping)))
-> NormalizedFilePath
-> MaybeT IdeAction (v, PositionMapping)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. k -> NormalizedFilePath -> IdeAction (Maybe (v, PositionMapping))
forall k v.
IdeRule k v =>
k -> NormalizedFilePath -> IdeAction (Maybe (v, PositionMapping))
Shake.useWithStaleFast k
k

-- ----------------------------------------------------------------------------
-- Location wrappers
-- ----------------------------------------------------------------------------

-- |ExceptT version of `uriToFilePath` that throws a PluginInvalidParams upon
-- failure
uriToFilePathE :: Monad m => LSP.Uri -> ExceptT PluginError m FilePath
uriToFilePathE :: forall (m :: * -> *).
Monad m =>
Uri -> ExceptT PluginError m String
uriToFilePathE Uri
uri = PluginError -> MaybeT m String -> ExceptT PluginError m String
forall (m :: * -> *) e a.
Functor m =>
e -> MaybeT m a -> ExceptT e m a
maybeToExceptT (Text -> PluginError
PluginInvalidParams (String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String
"uriToFilePath' failed. Uri:" String -> String -> String
forall a. Semigroup a => a -> a -> a
<>  Uri -> String
forall a. Show a => a -> String
show Uri
uri)) (MaybeT m String -> ExceptT PluginError m String)
-> MaybeT m String -> ExceptT PluginError m String
forall a b. (a -> b) -> a -> b
$ Uri -> MaybeT m String
forall (m :: * -> *). Monad m => Uri -> MaybeT m String
uriToFilePathMT Uri
uri

-- |MaybeT version of `uriToFilePath`
uriToFilePathMT :: Monad m => LSP.Uri -> MaybeT m FilePath
uriToFilePathMT :: forall (m :: * -> *). Monad m => Uri -> MaybeT m String
uriToFilePathMT = m (Maybe String) -> MaybeT m String
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (m (Maybe String) -> MaybeT m String)
-> (Uri -> m (Maybe String)) -> Uri -> MaybeT m String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe String -> m (Maybe String)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe String -> m (Maybe String))
-> (Uri -> Maybe String) -> Uri -> m (Maybe String)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Uri -> Maybe String
Location.uriToFilePath'

-- ----------------------------------------------------------------------------
-- PositionMapping wrappers
-- ----------------------------------------------------------------------------

-- |ExceptT version of `toCurrentPosition` that throws a PluginInvalidUserState
-- upon failure
toCurrentPositionE :: Monad m => PositionMapping -> LSP.Position -> ExceptT PluginError m LSP.Position
toCurrentPositionE :: forall (m :: * -> *).
Monad m =>
PositionMapping -> Position -> ExceptT PluginError m Position
toCurrentPositionE PositionMapping
mapping = PluginError -> MaybeT m Position -> ExceptT PluginError m Position
forall (m :: * -> *) e a.
Functor m =>
e -> MaybeT m a -> ExceptT e m a
maybeToExceptT (Text -> PluginError
PluginInvalidUserState Text
"toCurrentPosition")(MaybeT m Position -> ExceptT PluginError m Position)
-> (Position -> MaybeT m Position)
-> Position
-> ExceptT PluginError m Position
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PositionMapping -> Position -> MaybeT m Position
forall (m :: * -> *).
Monad m =>
PositionMapping -> Position -> MaybeT m Position
toCurrentPositionMT PositionMapping
mapping

-- |MaybeT version of `toCurrentPosition`
toCurrentPositionMT :: Monad m => PositionMapping -> LSP.Position -> MaybeT m LSP.Position
toCurrentPositionMT :: forall (m :: * -> *).
Monad m =>
PositionMapping -> Position -> MaybeT m Position
toCurrentPositionMT PositionMapping
mapping = m (Maybe Position) -> MaybeT m Position
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (m (Maybe Position) -> MaybeT m Position)
-> (Position -> m (Maybe Position))
-> Position
-> MaybeT m Position
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Position -> m (Maybe Position)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Position -> m (Maybe Position))
-> (Position -> Maybe Position) -> Position -> m (Maybe Position)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PositionMapping -> Position -> Maybe Position
toCurrentPosition PositionMapping
mapping

-- |ExceptT version of `fromCurrentPosition` that throws a
-- PluginInvalidUserState upon failure
fromCurrentPositionE :: Monad m => PositionMapping -> LSP.Position -> ExceptT PluginError m LSP.Position
fromCurrentPositionE :: forall (m :: * -> *).
Monad m =>
PositionMapping -> Position -> ExceptT PluginError m Position
fromCurrentPositionE PositionMapping
mapping = PluginError -> MaybeT m Position -> ExceptT PluginError m Position
forall (m :: * -> *) e a.
Functor m =>
e -> MaybeT m a -> ExceptT e m a
maybeToExceptT (Text -> PluginError
PluginInvalidUserState Text
"fromCurrentPosition") (MaybeT m Position -> ExceptT PluginError m Position)
-> (Position -> MaybeT m Position)
-> Position
-> ExceptT PluginError m Position
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PositionMapping -> Position -> MaybeT m Position
forall (m :: * -> *).
Monad m =>
PositionMapping -> Position -> MaybeT m Position
fromCurrentPositionMT PositionMapping
mapping

-- |MaybeT version of `fromCurrentPosition`
fromCurrentPositionMT :: Monad m => PositionMapping -> LSP.Position -> MaybeT m LSP.Position
fromCurrentPositionMT :: forall (m :: * -> *).
Monad m =>
PositionMapping -> Position -> MaybeT m Position
fromCurrentPositionMT PositionMapping
mapping = m (Maybe Position) -> MaybeT m Position
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (m (Maybe Position) -> MaybeT m Position)
-> (Position -> m (Maybe Position))
-> Position
-> MaybeT m Position
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Position -> m (Maybe Position)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Position -> m (Maybe Position))
-> (Position -> Maybe Position) -> Position -> m (Maybe Position)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PositionMapping -> Position -> Maybe Position
fromCurrentPosition PositionMapping
mapping

-- |ExceptT version of `toCurrentRange` that throws a PluginInvalidUserState
-- upon failure
toCurrentRangeE :: Monad m => PositionMapping -> LSP.Range -> ExceptT PluginError m LSP.Range
toCurrentRangeE :: forall (m :: * -> *).
Monad m =>
PositionMapping -> Range -> ExceptT PluginError m Range
toCurrentRangeE PositionMapping
mapping = PluginError -> MaybeT m Range -> ExceptT PluginError m Range
forall (m :: * -> *) e a.
Functor m =>
e -> MaybeT m a -> ExceptT e m a
maybeToExceptT (Text -> PluginError
PluginInvalidUserState Text
"toCurrentRange") (MaybeT m Range -> ExceptT PluginError m Range)
-> (Range -> MaybeT m Range)
-> Range
-> ExceptT PluginError m Range
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PositionMapping -> Range -> MaybeT m Range
forall (m :: * -> *).
Monad m =>
PositionMapping -> Range -> MaybeT m Range
toCurrentRangeMT PositionMapping
mapping

-- |MaybeT version of `toCurrentRange`
toCurrentRangeMT :: Monad m => PositionMapping -> LSP.Range -> MaybeT m LSP.Range
toCurrentRangeMT :: forall (m :: * -> *).
Monad m =>
PositionMapping -> Range -> MaybeT m Range
toCurrentRangeMT PositionMapping
mapping = m (Maybe Range) -> MaybeT m Range
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (m (Maybe Range) -> MaybeT m Range)
-> (Range -> m (Maybe Range)) -> Range -> MaybeT m Range
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Range -> m (Maybe Range)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Range -> m (Maybe Range))
-> (Range -> Maybe Range) -> Range -> m (Maybe Range)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PositionMapping -> Range -> Maybe Range
toCurrentRange PositionMapping
mapping

-- |ExceptT version of `fromCurrentRange` that throws a PluginInvalidUserState
-- upon failure
fromCurrentRangeE :: Monad m => PositionMapping -> LSP.Range -> ExceptT PluginError m LSP.Range
fromCurrentRangeE :: forall (m :: * -> *).
Monad m =>
PositionMapping -> Range -> ExceptT PluginError m Range
fromCurrentRangeE PositionMapping
mapping = PluginError -> MaybeT m Range -> ExceptT PluginError m Range
forall (m :: * -> *) e a.
Functor m =>
e -> MaybeT m a -> ExceptT e m a
maybeToExceptT (Text -> PluginError
PluginInvalidUserState Text
"fromCurrentRange") (MaybeT m Range -> ExceptT PluginError m Range)
-> (Range -> MaybeT m Range)
-> Range
-> ExceptT PluginError m Range
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PositionMapping -> Range -> MaybeT m Range
forall (m :: * -> *).
Monad m =>
PositionMapping -> Range -> MaybeT m Range
fromCurrentRangeMT PositionMapping
mapping

-- |MaybeT version of `fromCurrentRange`
fromCurrentRangeMT :: Monad m => PositionMapping -> LSP.Range -> MaybeT m LSP.Range
fromCurrentRangeMT :: forall (m :: * -> *).
Monad m =>
PositionMapping -> Range -> MaybeT m Range
fromCurrentRangeMT PositionMapping
mapping = m (Maybe Range) -> MaybeT m Range
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (m (Maybe Range) -> MaybeT m Range)
-> (Range -> m (Maybe Range)) -> Range -> MaybeT m Range
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Range -> m (Maybe Range)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Range -> m (Maybe Range))
-> (Range -> Maybe Range) -> Range -> m (Maybe Range)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PositionMapping -> Range -> Maybe Range
fromCurrentRange PositionMapping
mapping

-- ----------------------------------------------------------------------------
-- Diagnostics
-- ----------------------------------------------------------------------------

-- | @'activeDiagnosticsInRangeMT' shakeExtras nfp range@ computes the
-- 'FileDiagnostic' 's that HLS produced and overlap with the given @range@.
--
-- This function is to be used whenever we need an authoritative source of truth
-- for which diagnostics are shown to the user.
-- These diagnostics can be used to provide various IDE features, for example
-- CodeActions, CodeLenses, or refactorings.
--
-- However, why do we need this when computing 'CodeAction's? A 'CodeActionParam'
-- has the 'CodeActionContext' which already contains the diagnostics!
-- But according to the LSP docs, the server shouldn't rely that these Diagnostic
-- are actually up-to-date and accurately reflect the state of the document.
--
-- From the LSP docs:
-- > An array of diagnostics known on the client side overlapping the range
-- > provided to the `textDocument/codeAction` request. They are provided so
-- > that the server knows which errors are currently presented to the user
-- > for the given range. There is no guarantee that these accurately reflect
-- > the error state of the resource. The primary parameter
-- > to compute code actions is the provided range.
--
-- Thus, even when the client sends us the context, we should compute the
-- diagnostics on the server side.
activeDiagnosticsInRangeMT :: MonadIO m => Shake.ShakeExtras -> NormalizedFilePath -> LSP.Range -> MaybeT m [FileDiagnostic]
activeDiagnosticsInRangeMT :: forall (m :: * -> *).
MonadIO m =>
ShakeExtras
-> NormalizedFilePath -> Range -> MaybeT m [FileDiagnostic]
activeDiagnosticsInRangeMT ShakeExtras
ide NormalizedFilePath
nfp Range
range = do
    m (Maybe [FileDiagnostic]) -> MaybeT m [FileDiagnostic]
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (m (Maybe [FileDiagnostic]) -> MaybeT m [FileDiagnostic])
-> m (Maybe [FileDiagnostic]) -> MaybeT m [FileDiagnostic]
forall a b. (a -> b) -> a -> b
$ IO (Maybe [FileDiagnostic]) -> m (Maybe [FileDiagnostic])
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe [FileDiagnostic]) -> m (Maybe [FileDiagnostic]))
-> IO (Maybe [FileDiagnostic]) -> m (Maybe [FileDiagnostic])
forall a b. (a -> b) -> a -> b
$ STM (Maybe [FileDiagnostic]) -> IO (Maybe [FileDiagnostic])
forall a. STM a -> IO a
atomically (STM (Maybe [FileDiagnostic]) -> IO (Maybe [FileDiagnostic]))
-> STM (Maybe [FileDiagnostic]) -> IO (Maybe [FileDiagnostic])
forall a b. (a -> b) -> a -> b
$ do
        Maybe [FileDiagnostic]
mDiags <- NormalizedUri
-> Map NormalizedUri [FileDiagnostic]
-> STM (Maybe [FileDiagnostic])
forall key value.
Hashable key =>
key -> Map key value -> STM (Maybe value)
STM.lookup (NormalizedFilePath -> NormalizedUri
LSP.normalizedFilePathToUri NormalizedFilePath
nfp) (ShakeExtras -> Map NormalizedUri [FileDiagnostic]
Shake.publishedDiagnostics ShakeExtras
ide)
        case Maybe [FileDiagnostic]
mDiags of
            Maybe [FileDiagnostic]
Nothing -> Maybe [FileDiagnostic] -> STM (Maybe [FileDiagnostic])
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe [FileDiagnostic]
forall a. Maybe a
Nothing
            Just [FileDiagnostic]
fileDiags -> do
                Maybe [FileDiagnostic] -> STM (Maybe [FileDiagnostic])
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe [FileDiagnostic] -> STM (Maybe [FileDiagnostic]))
-> Maybe [FileDiagnostic] -> STM (Maybe [FileDiagnostic])
forall a b. (a -> b) -> a -> b
$ [FileDiagnostic] -> Maybe [FileDiagnostic]
forall a. a -> Maybe a
Just ([FileDiagnostic] -> Maybe [FileDiagnostic])
-> [FileDiagnostic] -> Maybe [FileDiagnostic]
forall a b. (a -> b) -> a -> b
$ (FileDiagnostic -> Bool) -> [FileDiagnostic] -> [FileDiagnostic]
forall a. (a -> Bool) -> [a] -> [a]
filter FileDiagnostic -> Bool
diagRangeOverlaps [FileDiagnostic]
fileDiags
    where
        diagRangeOverlaps :: FileDiagnostic -> Bool
diagRangeOverlaps = \FileDiagnostic
fileDiag ->
            Range -> Range -> Bool
rangesOverlap Range
range (FileDiagnostic
fileDiag FileDiagnostic -> Getting Range FileDiagnostic Range -> Range
forall s a. s -> Getting a s a -> a
^. (Diagnostic -> Const Range Diagnostic)
-> FileDiagnostic -> Const Range FileDiagnostic
Lens' FileDiagnostic Diagnostic
fdLspDiagnosticL ((Diagnostic -> Const Range Diagnostic)
 -> FileDiagnostic -> Const Range FileDiagnostic)
-> ((Range -> Const Range Range)
    -> Diagnostic -> Const Range Diagnostic)
-> Getting Range FileDiagnostic Range
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Range -> Const Range Range)
-> Diagnostic -> Const Range Diagnostic
forall s a. HasRange s a => Lens' s a
Lens' Diagnostic Range
LSP.range)

-- | Just like 'activeDiagnosticsInRangeMT'. See the docs of 'activeDiagnosticsInRangeMT' for details.
activeDiagnosticsInRange :: MonadIO m => Shake.ShakeExtras -> NormalizedFilePath -> LSP.Range -> m (Maybe [FileDiagnostic])
activeDiagnosticsInRange :: forall (m :: * -> *).
MonadIO m =>
ShakeExtras
-> NormalizedFilePath -> Range -> m (Maybe [FileDiagnostic])
activeDiagnosticsInRange ShakeExtras
ide NormalizedFilePath
nfp Range
range = MaybeT m [FileDiagnostic] -> m (Maybe [FileDiagnostic])
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (ShakeExtras
-> NormalizedFilePath -> Range -> MaybeT m [FileDiagnostic]
forall (m :: * -> *).
MonadIO m =>
ShakeExtras
-> NormalizedFilePath -> Range -> MaybeT m [FileDiagnostic]
activeDiagnosticsInRangeMT ShakeExtras
ide NormalizedFilePath
nfp Range
range)

-- ----------------------------------------------------------------------------
-- Formatting handlers
-- ----------------------------------------------------------------------------

-- `mkFormattingHandlers` was moved here from hls-plugin-api package so that
-- `mkFormattingHandlers` can refer to `IdeState`. `IdeState` is defined in the
-- ghcide package, but hls-plugin-api does not depend on ghcide, so `IdeState`
-- is not in scope there.

mkFormattingHandlers :: FormattingHandler IdeState -> PluginHandlers IdeState
mkFormattingHandlers :: FormattingHandler IdeState -> PluginHandlers IdeState
mkFormattingHandlers FormattingHandler IdeState
f = SClientMethod 'Method_TextDocumentFormatting
-> PluginMethodHandler IdeState 'Method_TextDocumentFormatting
-> PluginHandlers IdeState
forall ideState (m :: Method 'ClientToServer 'Request).
PluginRequestMethod m =>
SClientMethod m
-> PluginMethodHandler ideState m -> PluginHandlers ideState
mkPluginHandler SClientMethod 'Method_TextDocumentFormatting
SMethod_TextDocumentFormatting ( SClientMethod 'Method_TextDocumentFormatting
-> PluginMethodHandler IdeState 'Method_TextDocumentFormatting
forall {f :: MessageDirection} {t :: MessageKind}
       (m :: Method f t).
FormattingMethod m =>
SMethod m -> PluginMethodHandler IdeState m
provider SClientMethod 'Method_TextDocumentFormatting
SMethod_TextDocumentFormatting)
                      PluginHandlers IdeState
-> PluginHandlers IdeState -> PluginHandlers IdeState
forall a. Semigroup a => a -> a -> a
<> SClientMethod 'Method_TextDocumentRangeFormatting
-> PluginMethodHandler IdeState 'Method_TextDocumentRangeFormatting
-> PluginHandlers IdeState
forall ideState (m :: Method 'ClientToServer 'Request).
PluginRequestMethod m =>
SClientMethod m
-> PluginMethodHandler ideState m -> PluginHandlers ideState
mkPluginHandler SClientMethod 'Method_TextDocumentRangeFormatting
SMethod_TextDocumentRangeFormatting (SClientMethod 'Method_TextDocumentRangeFormatting
-> PluginMethodHandler IdeState 'Method_TextDocumentRangeFormatting
forall {f :: MessageDirection} {t :: MessageKind}
       (m :: Method f t).
FormattingMethod m =>
SMethod m -> PluginMethodHandler IdeState m
provider SClientMethod 'Method_TextDocumentRangeFormatting
SMethod_TextDocumentRangeFormatting)
  where
    provider :: forall m. FormattingMethod m => SMethod m -> PluginMethodHandler IdeState m
    provider :: forall {f :: MessageDirection} {t :: MessageKind}
       (m :: Method f t).
FormattingMethod m =>
SMethod m -> PluginMethodHandler IdeState m
provider SMethod m
m IdeState
ide PluginId
_pid MessageParams m
params
      | Just NormalizedFilePath
nfp <- NormalizedUri -> Maybe NormalizedFilePath
LSP.uriToNormalizedFilePath (NormalizedUri -> Maybe NormalizedFilePath)
-> NormalizedUri -> Maybe NormalizedFilePath
forall a b. (a -> b) -> a -> b
$ Uri -> NormalizedUri
LSP.toNormalizedUri Uri
uri = do
        Maybe Rope
contentsMaybe <- IO (Maybe Rope)
-> ExceptT PluginError (HandlerM Config) (Maybe Rope)
forall a. IO a -> ExceptT PluginError (HandlerM Config) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe Rope)
 -> ExceptT PluginError (HandlerM Config) (Maybe Rope))
-> IO (Maybe Rope)
-> ExceptT PluginError (HandlerM Config) (Maybe Rope)
forall a b. (a -> b) -> a -> b
$ String -> IdeState -> Action (Maybe Rope) -> IO (Maybe Rope)
forall a. String -> IdeState -> Action a -> IO a
runAction String
"mkFormattingHandlers" IdeState
ide (Action (Maybe Rope) -> IO (Maybe Rope))
-> Action (Maybe Rope) -> IO (Maybe Rope)
forall a b. (a -> b) -> a -> b
$ NormalizedFilePath -> Action (Maybe Rope)
getFileContents NormalizedFilePath
nfp
        case Maybe Rope
contentsMaybe of
          Just Rope
contents -> do
            let (FormattingType
typ, Maybe ProgressToken
mtoken) = case SMethod m
m of
                  SMethod m
SMethod_TextDocumentFormatting -> (FormattingType
FormatText, DocumentFormattingParams
MessageParams m
params DocumentFormattingParams
-> Getting
     (Maybe ProgressToken)
     DocumentFormattingParams
     (Maybe ProgressToken)
-> Maybe ProgressToken
forall s a. s -> Getting a s a -> a
^. Getting
  (Maybe ProgressToken)
  DocumentFormattingParams
  (Maybe ProgressToken)
forall s a. HasWorkDoneToken s a => Lens' s a
Lens' DocumentFormattingParams (Maybe ProgressToken)
LSP.workDoneToken)
                  SMethod m
SMethod_TextDocumentRangeFormatting -> (Range -> FormattingType
FormatRange (DocumentRangeFormattingParams
MessageParams m
params DocumentRangeFormattingParams
-> Getting Range DocumentRangeFormattingParams Range -> Range
forall s a. s -> Getting a s a -> a
^. Getting Range DocumentRangeFormattingParams Range
forall s a. HasRange s a => Lens' s a
Lens' DocumentRangeFormattingParams Range
LSP.range), DocumentRangeFormattingParams
MessageParams m
params DocumentRangeFormattingParams
-> Getting
     (Maybe ProgressToken)
     DocumentRangeFormattingParams
     (Maybe ProgressToken)
-> Maybe ProgressToken
forall s a. s -> Getting a s a -> a
^. Getting
  (Maybe ProgressToken)
  DocumentRangeFormattingParams
  (Maybe ProgressToken)
forall s a. HasWorkDoneToken s a => Lens' s a
Lens' DocumentRangeFormattingParams (Maybe ProgressToken)
LSP.workDoneToken)
                  SMethod m
_ -> String -> (FormattingType, Maybe ProgressToken)
forall a. HasCallStack => String -> a
Prelude.error String
"mkFormattingHandlers: impossible"
            FormattingHandler IdeState
f IdeState
ide Maybe ProgressToken
mtoken FormattingType
typ (Rope -> Text
Rope.toText Rope
contents) NormalizedFilePath
nfp FormattingOptions
opts
          Maybe Rope
Nothing -> PluginError
-> ExceptT PluginError (HandlerM Config) ([TextEdit] |? Null)
forall a. PluginError -> ExceptT PluginError (HandlerM Config) a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (PluginError
 -> ExceptT PluginError (HandlerM Config) ([TextEdit] |? Null))
-> PluginError
-> ExceptT PluginError (HandlerM Config) ([TextEdit] |? Null)
forall a b. (a -> b) -> a -> b
$ Text -> PluginError
PluginInvalidParams (Text -> PluginError) -> Text -> PluginError
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String
"Formatter plugin: could not get file contents for " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Uri -> String
forall a. Show a => a -> String
show Uri
uri

      | Bool
otherwise = PluginError
-> ExceptT PluginError (HandlerM Config) (MessageResult m)
forall a. PluginError -> ExceptT PluginError (HandlerM Config) a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (PluginError
 -> ExceptT PluginError (HandlerM Config) (MessageResult m))
-> PluginError
-> ExceptT PluginError (HandlerM Config) (MessageResult m)
forall a b. (a -> b) -> a -> b
$ Text -> PluginError
PluginInvalidParams (Text -> PluginError) -> Text -> PluginError
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String
"Formatter plugin: uriToFilePath failed for: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Uri -> String
forall a. Show a => a -> String
show Uri
uri
      where
        uri :: Uri
uri = MessageParams m
params MessageParams m -> Getting Uri (MessageParams m) Uri -> Uri
forall s a. s -> Getting a s a -> a
^. (TextDocumentIdentifier -> Const Uri TextDocumentIdentifier)
-> MessageParams m -> Const Uri (MessageParams m)
forall s a. HasTextDocument s a => Lens' s a
Lens' (MessageParams m) TextDocumentIdentifier
LSP.textDocument ((TextDocumentIdentifier -> Const Uri TextDocumentIdentifier)
 -> MessageParams m -> Const Uri (MessageParams m))
-> ((Uri -> Const Uri Uri)
    -> TextDocumentIdentifier -> Const Uri TextDocumentIdentifier)
-> Getting Uri (MessageParams m) Uri
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Uri -> Const Uri Uri)
-> TextDocumentIdentifier -> Const Uri TextDocumentIdentifier
forall s a. HasUri s a => Lens' s a
Lens' TextDocumentIdentifier Uri
LSP.uri
        opts :: FormattingOptions
opts = MessageParams m
params MessageParams m
-> Getting FormattingOptions (MessageParams m) FormattingOptions
-> FormattingOptions
forall s a. s -> Getting a s a -> a
^. Getting FormattingOptions (MessageParams m) FormattingOptions
forall s a. HasOptions s a => Lens' s a
Lens' (MessageParams m) FormattingOptions
LSP.options